/[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 585 by dpavlin, Wed Jul 5 19:52:45 2006 UTC revision 697 by dpavlin, Mon Sep 25 09:49:28 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.07  Version 0.12
20    
21  =cut  =cut
22    
23  our $VERSION = '0.07';  our $VERSION = '0.12';
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,  
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 108  sub new { Line 107  sub new {
107          #eval $self->{module} .'->import';          #eval $self->{module} .'->import';
108    
109          # check if required subclasses are implemented          # check if required subclasses are implemented
110          foreach my $subclass (qw/open_db fetch_rec init/) {          foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
111                  my $n = $self->{module} . '::' . $subclass;                  my $n = $self->{module} . '::' . $subclass;
112                  if (! defined &{ $n }) {                  if (! defined &{ $n }) {
113                          my $missing = "missing $subclass in $self->{module}";                          my $missing = "missing $subclass in $self->{module}";
# Line 160  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,
# 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            modify_file => 'conf/modify/mapping.map',
176   );   );
177    
178  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
179    
180  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.
181    
# Line 179  C<limit> is optional parametar to read j Line 183  C<limit> is optional parametar to read j
183    
184  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
185    
186  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
187  lookup.  lookup.
188    
189    C<modify_records> specify mapping from subfields to delimiters or from
190    delimiters to subfields, as well as oprations on fields (if subfield is
191    defined as C<*>.
192    
193    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
194    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
195    overrides C<modify_records> if both exists for same input.
196    
197  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
198  parametars, see also C<size>.  parametars, see also C<size>.
199    
# Line 198  sub open { Line 210  sub open {
210                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
211    
212          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
213          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
214    
215          # store data in object          # store data in object
216          $self->{'input_code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
# Line 206  sub open { Line 218  sub open {
218                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
219          }          }
220    
         # create Text::Iconv object  
         $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!  
   
221          my $filter_ref;          my $filter_ref;
222            my $recode_regex;
223            my $recode_map;
224    
225          if ($self->{recode}) {          if ($self->{recode}) {
226                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
227                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
228                          $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)");
229                  } else {                  } else {
                         my $recode;  
230                          while (@r) {                          while (@r) {
231                                  my $from = shift @r;                                  my $from = shift @r;
232                                  my $to = shift @r;                                  my $to = shift @r;
233                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
234                          }                          }
235    
236                          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;  
                         };  
237    
238                            $log->debug("using recode regex: $recode_regex");
239                  }                  }
240    
241          }          }
242    
243            my $rec_regex;
244            if (my $p = $arg->{modify_file}) {
245                    $log->debug("using modify_file $p");
246                    $rec_regex = $self->modify_file_regexps( $p );
247            } elsif (my $h = $arg->{modify_records}) {
248                    $log->debug("using modify_records ", Dumper( $h ));
249                    $rec_regex = $self->modify_record_regexps(%{ $h });
250            }
251            $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
252    
253          my ($db, $size) = $self->{open_db}->( $self,          my ($db, $size) = $self->{open_db}->( $self,
254                  path => $arg->{path},                  path => $arg->{path},
255                  filter => $filter_ref,  #               filter => sub {
256    #                       my ($l,$f_nr) = @_;
257    #                       return unless defined($l);
258    #                       from_to($l, $code_page, $self->{'encoding'});
259    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
260    #                       return $l;
261    #               },
262                  %{ $arg },                  %{ $arg },
263          );          );
264    
# Line 279  sub open { Line 298  sub open {
298    
299                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
300    
301                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $self->{fetch_rec}->($self, $pos, sub {
302                                    my ($l,$f_nr) = @_;
303    #                               return unless defined($l);
304    #                               return $l unless ($rec_regex && $f_nr);
305    
306                                    $log->debug("-=> $f_nr ## $l");
307    
308                                    # codepage conversion and recode_regex
309                                    from_to($l, $code_page, $self->{'encoding'});
310                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
311    
312                                    # apply regexps
313                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
314                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
315                                            my $c = 0;
316                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
317                                                    my $old_l = $l;
318                                                    eval '$l =~ ' . $r;
319                                                    if ($old_l ne $l) {
320                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
321                                                    }
322                                                    $log->error("error applying regex: $r") if ($@);
323                                            }
324                                    }
325    
326                                    $log->debug("<=- $f_nr ## $l");
327                                    return $l;
328                    });
329    
330                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { Dumper($rec) });
331    
# Line 300  sub open { Line 346  sub open {
346    
347                  # update counters for statistics                  # update counters for statistics
348                  if ($self->{stats}) {                  if ($self->{stats}) {
349                          map {  
350                                  my $fld = $_;                          # fetch clean record with regexpes applied for statistics
351                            my $rec = $self->{fetch_rec}->($self, $pos);
352    
353                            foreach my $fld (keys %{ $rec }) {
354                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
355                                  if (ref($rec->{ $fld }) eq 'ARRAY') {  
356                                          map {                                  $log->logdie("invalid record fild $fld, not ARRAY")
357                                                  if (ref($_) eq 'HASH') {                                          unless (ref($rec->{ $fld }) eq 'ARRAY');
358                                                          map {          
359                                                                  $self->{_stats}->{sf}->{ $fld }->{ $_ }++;                                  foreach my $row (@{ $rec->{$fld} }) {
360                                                          } keys %{ $_ };  
361                                                  } else {                                          if (ref($row) eq 'HASH') {
362                                                          $self->{_stats}->{repeatable}->{ $fld }++;  
363                                                    foreach my $sf (keys %{ $row }) {
364                                                            next if ($sf eq 'subfields');
365                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
366                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
367                                                                            if (ref($row->{$sf}) eq 'ARRAY');
368                                                  }                                                  }
369                                          } @{ $rec->{$fld} };  
370                                            } else {
371                                                    $self->{_stats}->{repeatable}->{ $fld }++;
372                                            }
373                                  }                                  }
374                          } keys %{ $rec };                          }
375                  }                  }
376    
377                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
# Line 469  sub stats { Line 526  sub stats {
526    
527                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
528                                  map {                                  map {
529                                          $o .= sprintf(" %s:%d", $_, $s->{sf}->{$f}->{$_});                                          $o .= sprintf(" %s:%d%s", $_,
530                                                    $s->{sf}->{$f}->{$_}->{count},
531                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
532                                            );
533                                  } sort keys %{ $s->{sf}->{$f} };                                  } sort keys %{ $s->{sf}->{$f} };
534                          }                          }
535    
# Line 486  sub stats { Line 546  sub stats {
546          return $out;          return $out;
547  }  }
548    
549    =head2 dump
550    
551    Display humanly readable dump of record
552    
553    =cut
554    
555    sub dump {
556            my $self = shift;
557    
558            return $self->{dump_rec}->($self, $self->{pos});
559    
560    }
561    
562    =head2 modify_record_regexps
563    
564    Generate hash with regexpes to be applied using l<filter>.
565    
566      my $regexpes = $input->modify_record_regexps(
567                    900 => { '^a' => { ' : ' => '^b' } },
568                    901 => { '*' => { '^b' => ' ; ' } },
569      );
570    
571    =cut
572    
573    sub _get_regex {
574            my ($sf,$from,$to) = @_;
575            if ($sf =~ /^\^/) {
576                    return
577                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
578            } else {
579                    return
580                            's/\Q'. $from .'\E/'. $to .'/g';
581            }
582    }
583    
584    sub modify_record_regexps {
585            my $self = shift;
586            my $modify_record = {@_};
587    
588            my $regexpes;
589    
590            my $log = $self->_get_logger();
591    
592            foreach my $f (keys %$modify_record) {
593                    $log->debug("field: $f");
594    
595                    foreach my $sf (keys %{ $modify_record->{$f} }) {
596                            $log->debug("subfield: $sf");
597    
598                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
599                                    my $to = $modify_record->{$f}->{$sf}->{$from};
600                                    #die "no field?" unless defined($to);
601                                    $log->debug("transform: |$from| -> |$to|");
602    
603                                    my $regex = _get_regex($sf,$from,$to);
604                                    push @{ $regexpes->{$f} }, $regex;
605                                    $log->debug("regex: $regex");
606                            }
607                    }
608            }
609    
610            return $regexpes;
611    }
612    
613    =head2 modify_file_regexps
614    
615    Generate hash with regexpes to be applied using l<filter> from
616    pseudo hash/yaml format for regex mappings.
617    
618    It should be obvious:
619    
620            200
621              '^a'
622                ' : ' => '^e'
623                ' = ' => '^d'
624    
625    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
626    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
627    
628      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
629    
630    On undef path it will just return.
631    
632    =cut
633    
634    sub modify_file_regexps {
635            my $self = shift;
636    
637            my $modify_path = shift || return;
638    
639            my $log = $self->_get_logger();
640    
641            my $regexpes;
642    
643            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
644    
645            my ($f,$sf);
646    
647            while(<$fh>) {
648                    chomp;
649                    next if (/^#/ || /^\s*$/);
650    
651                    if (/^\s*(\d+)\s*$/) {
652                            $f = $1;
653                            $log->debug("field: $f");
654                            next;
655                    } elsif (/^\s*'([^']*)'\s*$/) {
656                            $sf = $1;
657                            $log->die("can't define subfiled before field in: $_") unless ($f);
658                            $log->debug("subfield: $sf");
659                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
660                            my ($from,$to) = ($1, $2);
661    
662                            $log->debug("transform: |$from| -> |$to|");
663    
664                            my $regex = _get_regex($sf,$from,$to);
665                            push @{ $regexpes->{$f} }, $regex;
666                            $log->debug("regex: $regex");
667                    }
668            }
669    
670            return $regexpes;
671    }
672    
673  =head1 MEMORY USAGE  =head1 MEMORY USAGE
674    
675  C<low_mem> options is double-edged sword. If enabled, WebPAC  C<low_mem> options is double-edged sword. If enabled, WebPAC
# Line 523  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 707  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
707    
708  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
709    
710  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
711    
712  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
713  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.585  
changed lines
  Added in v.697
  ViewVC Help
Powered by ViewVC 1.1.26