/[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 507 by dpavlin, Mon May 15 13:15:01 2006 UTC revision 726 by dpavlin, Fri Sep 29 19:52:17 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.13
20    
21  =cut  =cut
22    
23  our $VERSION = '0.05';  our $VERSION = '0.13';
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_path = $self->{module};
102          $module =~ s#::#/#g;          $module_path =~ s#::#/#g;
103          $module .= '.pm';          $module_path .= '.pm';
104          $log->debug("require low-level module $self->{module} from $module");          $log->debug("require low-level module $self->{module} from $module_path");
105    
106          require $module;          require $module_path;
         #eval $self->{module} .'->import';  
107    
108          # check if required subclasses are implemented          # check if required subclasses are implemented
109          foreach my $subclass (qw/open_db fetch_rec init/) {          foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
110                  my $n = $self->{module} . '::' . $subclass;                  # FIXME
                 if (! defined &{ $n }) {  
                         my $missing = "missing $subclass in $self->{module}";  
                         $self->{$subclass} = sub { $log->logwarn($missing) };  
                 } else {  
                         $self->{$subclass} = \&{ $n };  
                 }  
         }  
   
         if ($self->{init}) {  
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
111          }          }
112    
113          $self->{'code_page'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
114    
115          # running with low_mem flag? well, use DBM::Deep then.          # running with low_mem flag? well, use DBM::Deep then.
116          if ($self->{'low_mem'}) {          if ($self->{'low_mem'}) {
# Line 158  This function will read whole database i Line 147  This function will read whole database i
147    
148   $input->open(   $input->open(
149          path => '/path/to/database/file',          path => '/path/to/database/file',
150          code_page => '852',          code_page => 'cp852',
151          limit => 500,          limit => 500,
152          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
153          stats => 1,          stats => 1,
154            lookup_coderef => sub {
155                    my $rec = shift;
156                    # store lookups
157            },
158            modify_records => {
159                    900 => { '^a' => { ' : ' => '^b' } },
160                    901 => { '*' => { '^b' => ' ; ' } },
161            },
162            modify_file => 'conf/modify/mapping.map',
163   );   );
164    
165  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
166    
167  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.
168    
# Line 173  C<limit> is optional parametar to read j Line 170  C<limit> is optional parametar to read j
170    
171  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
172    
173    C<lookup_coderef> is closure to called to save data into lookups
174    
175    C<modify_records> specify mapping from subfields to delimiters or from
176    delimiters to subfields, as well as oprations on fields (if subfield is
177    defined as C<*>.
178    
179    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
180    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
181    overrides C<modify_records> if both exists for same input.
182    
183  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
184  parametars, see also C<size>.  parametars, see also C<size>.
185    
# Line 184  sub open { Line 191  sub open {
191    
192          my $log = $self->_get_logger();          my $log = $self->_get_logger();
193    
194            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
195            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
196                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
197    
198            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
199    
200          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
201          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
202    
203          # store data in object          # store data in object
204          $self->{'input_code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
# Line 193  sub open { Line 206  sub open {
206                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
207          }          }
208    
         # create Text::Iconv object  
         $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});  
   
209          my $filter_ref;          my $filter_ref;
210            my $recode_regex;
211            my $recode_map;
212    
213          if ($self->{recode}) {          if ($self->{recode}) {
214                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
215                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
216                          $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)");
217                  } else {                  } else {
                         my $recode;  
218                          while (@r) {                          while (@r) {
219                                  my $from = shift @r;                                  my $from = shift @r;
220                                  my $to = shift @r;                                  my $to = shift @r;
221                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
222                          }                          }
223    
224                          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;  
                         };  
225    
226                            $log->debug("using recode regex: $recode_regex");
227                  }                  }
228    
229          }          }
230    
231          my ($db, $size) = $self->{open_db}->( $self,          my $rec_regex;
232            if (my $p = $arg->{modify_file}) {
233                    $log->debug("using modify_file $p");
234                    $rec_regex = $self->modify_file_regexps( $p );
235            } elsif (my $h = $arg->{modify_records}) {
236                    $log->debug("using modify_records ", Dumper( $h ));
237                    $rec_regex = $self->modify_record_regexps(%{ $h });
238            }
239            $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
240    
241            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
242    
243            my $ll_db = $class->new(
244                  path => $arg->{path},                  path => $arg->{path},
245                  filter => $filter_ref,  #               filter => sub {
246    #                       my ($l,$f_nr) = @_;
247    #                       return unless defined($l);
248    #                       from_to($l, $code_page, $self->{'encoding'});
249    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
250    #                       return $l;
251    #               },
252                    %{ $arg },
253          );          );
254    
255          unless (defined($db)) {          unless (defined($ll_db)) {
256                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
257                  return;                  return;
258          }          }
259    
260            my $size = $ll_db->size;
261    
262          unless ($size) {          unless ($size) {
263                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
264                  return;                  return;
# Line 243  sub open { Line 268  sub open {
268          my $to_rec = $size;          my $to_rec = $size;
269    
270          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
271                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
272                  $from_rec = $s;                  $from_rec = $s;
273          } else {          } else {
274                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec;
# Line 258  sub open { Line 283  sub open {
283          # store size for later          # store size for later
284          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
285    
286          $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]' : '');
287    
288          # read database          # read database
289          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
290    
291                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
292    
293                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
294                                    my ($l,$f_nr) = @_;
295    #                               return unless defined($l);
296    #                               return $l unless ($rec_regex && $f_nr);
297    
298                                    $log->debug("-=> $f_nr ## $l");
299    
300                                    # codepage conversion and recode_regex
301                                    from_to($l, $code_page, $self->{'encoding'});
302                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
303    
304                                    # apply regexps
305                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
306                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
307                                            my $c = 0;
308                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
309                                                    my $old_l = $l;
310                                                    eval '$l =~ ' . $r;
311                                                    if ($old_l ne $l) {
312                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
313                                                    }
314                                                    $log->error("error applying regex: $r") if ($@);
315                                            }
316                                    }
317    
318                                    $log->debug("<=- $f_nr ## $l");
319                                    return $l;
320                    });
321    
322                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { Dumper($rec) });
323    
# Line 282  sub open { Line 334  sub open {
334                  }                  }
335    
336                  # create lookup                  # create lookup
337                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
338    
339                  # update counters for statistics                  # update counters for statistics
340                  if ($self->{stats}) {                  if ($self->{stats}) {
341                          map {  
342                                  my $fld = $_;                          # fetch clean record with regexpes applied for statistics
343                            my $rec = $ll_db->fetch_rec($pos);
344    
345                            foreach my $fld (keys %{ $rec }) {
346                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
347                                  if (ref($rec->{ $fld }) eq 'ARRAY') {  
348                                          map {                                  $log->logdie("invalid record fild $fld, not ARRAY")
349                                                  if (ref($_) eq 'HASH') {                                          unless (ref($rec->{ $fld }) eq 'ARRAY');
350                                                          map {          
351                                                                  $self->{_stats}->{sf}->{ $fld }->{ $_ }++;                                  foreach my $row (@{ $rec->{$fld} }) {
352                                                          } keys %{ $_ };  
353                                                  } else {                                          if (ref($row) eq 'HASH') {
354                                                          $self->{_stats}->{repeatable}->{ $fld }++;  
355                                                    foreach my $sf (keys %{ $row }) {
356                                                            next if ($sf eq 'subfields');
357                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
358                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
359                                                                            if (ref($row->{$sf}) eq 'ARRAY');
360                                                  }                                                  }
361                                          } @{ $rec->{$fld} };  
362                                            } else {
363                                                    $self->{_stats}->{repeatable}->{ $fld }++;
364                                            }
365                                  }                                  }
366                          } keys %{ $rec };                          }
367                  }                  }
368    
369                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
# Line 451  sub stats { Line 514  sub stats {
514                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
515                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
516    
517                          my $o = sprintf("%4d %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
518    
519                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
520                                  map {                                  map {
521                                          $o .= sprintf(" %s:%d", $_, $s->{sf}->{$f}->{$_});                                          $o .= sprintf(" %s:%d%s", $_,
522                                                    $s->{sf}->{$f}->{$_}->{count},
523                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
524                                            );
525                                  } sort keys %{ $s->{sf}->{$f} };                                  } sort keys %{ $s->{sf}->{$f} };
526                          }                          }
527    
# Line 464  sub stats { Line 530  sub stats {
530                          }                          }
531    
532                          $o;                          $o;
533                  } sort { $a <=> $b } keys %{ $s->{fld} }                  } sort { $a cmp $b } keys %{ $s->{fld} }
534          );          );
535    
536          $log->debug( sub { Dumper($s) } );          $log->debug( sub { Dumper($s) } );
# Line 472  sub stats { Line 538  sub stats {
538          return $out;          return $out;
539  }  }
540    
541    =head2 dump
542    
543    Display humanly readable dump of record
544    
545    =cut
546    
547    sub dump {
548            my $self = shift;
549    
550            return $self->{dump_rec}->($self, $self->{pos});
551    
552    }
553    
554    =head2 modify_record_regexps
555    
556    Generate hash with regexpes to be applied using l<filter>.
557    
558      my $regexpes = $input->modify_record_regexps(
559                    900 => { '^a' => { ' : ' => '^b' } },
560                    901 => { '*' => { '^b' => ' ; ' } },
561      );
562    
563    =cut
564    
565    sub _get_regex {
566            my ($sf,$from,$to) = @_;
567            if ($sf =~ /^\^/) {
568                    return
569                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
570            } else {
571                    return
572                            's/\Q'. $from .'\E/'. $to .'/g';
573            }
574    }
575    
576    sub modify_record_regexps {
577            my $self = shift;
578            my $modify_record = {@_};
579    
580            my $regexpes;
581    
582            my $log = $self->_get_logger();
583    
584            foreach my $f (keys %$modify_record) {
585                    $log->debug("field: $f");
586    
587                    foreach my $sf (keys %{ $modify_record->{$f} }) {
588                            $log->debug("subfield: $sf");
589    
590                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
591                                    my $to = $modify_record->{$f}->{$sf}->{$from};
592                                    #die "no field?" unless defined($to);
593                                    $log->debug("transform: |$from| -> |$to|");
594    
595                                    my $regex = _get_regex($sf,$from,$to);
596                                    push @{ $regexpes->{$f} }, $regex;
597                                    $log->debug("regex: $regex");
598                            }
599                    }
600            }
601    
602            return $regexpes;
603    }
604    
605    =head2 modify_file_regexps
606    
607    Generate hash with regexpes to be applied using l<filter> from
608    pseudo hash/yaml format for regex mappings.
609    
610    It should be obvious:
611    
612            200
613              '^a'
614                ' : ' => '^e'
615                ' = ' => '^d'
616    
617    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
618    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
619    
620      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
621    
622    On undef path it will just return.
623    
624    =cut
625    
626    sub modify_file_regexps {
627            my $self = shift;
628    
629            my $modify_path = shift || return;
630    
631            my $log = $self->_get_logger();
632    
633            my $regexpes;
634    
635            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
636    
637            my ($f,$sf);
638    
639            while(<$fh>) {
640                    chomp;
641                    next if (/^#/ || /^\s*$/);
642    
643                    if (/^\s*(\d+)\s*$/) {
644                            $f = $1;
645                            $log->debug("field: $f");
646                            next;
647                    } elsif (/^\s*'([^']*)'\s*$/) {
648                            $sf = $1;
649                            $log->die("can't define subfiled before field in: $_") unless ($f);
650                            $log->debug("subfield: $sf");
651                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
652                            my ($from,$to) = ($1, $2);
653    
654                            $log->debug("transform: |$from| -> |$to|");
655    
656                            my $regex = _get_regex($sf,$from,$to);
657                            push @{ $regexpes->{$f} }, $regex;
658                            $log->debug("regex: $regex");
659                    }
660            }
661    
662            return $regexpes;
663    }
664    
665  =head1 MEMORY USAGE  =head1 MEMORY USAGE
666    
667  C<low_mem> options is double-edged sword. If enabled, WebPAC  C<low_mem> options is double-edged sword. If enabled, WebPAC
# Line 509  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 699  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
699    
700  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
701    
702  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
703    
704  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
705  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.507  
changed lines
  Added in v.726
  ViewVC Help
Powered by ViewVC 1.1.26