/[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!

Diff of /trunk/lib/WebPAC/Input.pm

Parent Directory | Revision Log | View Patch Patch

-revision 307 by dpavlin,
Tue Dec 20 00:03:04 2005 UTC
+revision 599 by dpavlin,
Thu Jul 13 13:55:19 2006 UTC
 Line 3 
 package WebPAC::Input;
  use warnings;
  use strict;
+ use blib;
  use WebPAC::Common;
  use base qw/WebPAC::Common/;
  use Text::Iconv;
+ use Data::Dumper;
  =head1 NAME
-Line 13 
 WebPAC::Input - read different file form
+Line 16 
 WebPAC::Input - read different file form
  =head1 VERSION
- Version 0.03
+ Version 0.09
  =cut
- our $VERSION = '0.03';
+ our $VERSION = '0.09';
  =head1 SYNOPSIS
-Line 36 
 C<fetch_rec> and optional C<init> functi
+Line 39 
 C<fetch_rec> and optional C<init> functi
  Perhaps a little code snippet.
-     use WebPAC::Input;
+         use WebPAC::Input;
-     my $db = WebPAC::Input->new(
+         my $db = WebPAC::Input->new(
-         module => 'WebPAC::Input::ISIS',
+                 module => 'WebPAC::Input::ISIS',
-                 config => $config,
-                 lookup => $lookup_obj,
                  low_mem => 1,
-     );
+         );
-     $db->open('/path/to/database');
+         $db->open( path => '/path/to/database' );
-     print "database size: ",$db->size,"\n";
+         print "database size: ",$db->size,"\n";
-     while (my $rec = $db->fetch) {
+         while (my $rec = $db->fetch) {
-     }
+                 # do something with $rec
+         }
-Line 60 
 Create new input database object.
+Line 62 
 Create new input database object.
    my $db = new WebPAC::Input(
          module => 'WebPAC::Input::MARC',
-         code_page => 'ISO-8859-2',
+         encoding => 'ISO-8859-2',
          low_mem => 1,
+         recode => 'char pairs',
+         no_progress_bar => 1,
    );
- 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
  L<WebPAC::Input::MARC>.
- Optional parametar C<code_page> specify application code page (which will be
+ Optional parametar C<encoding> specify application code page (which will be
  used internally). This should probably be your terminal encoding, and by
  default, it C<ISO-8859-2>.
  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
+ C<recode> is optional string constisting of character or words pairs that
+ should be replaced in input stream.
+ C<no_progress_bar> disables progress bar output on C<STDOUT>
  This function will also call low-level C<init> if it exists with same
  parametars.
-Line 85 
 sub new {
+Line 94 
 sub new {
          my $log = $self->_get_logger;
+         $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
+         $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
          $log->logconfess("specify low-level file format module") unless ($self->{module});
          my $module = $self->{module};
          $module =~ s#::#/#g;
-Line 110 
 sub new {
+Line 122 
 sub new {
                  $self->{init}->($self, @_);
          }
-         $self->{'code_page'} ||= 'ISO-8859-2';
+         $self->{'encoding'} ||= 'ISO-8859-2';
          # running with low_mem flag? well, use DBM::Deep then.
          if ($self->{'low_mem'}) {
-Line 151 
 This function will read whole database i
+Line 163 
 This function will read whole database i
          limit => 500,
          offset => 6000,
          lookup => $lookup_obj,
+         stats => 1,
+         lookup_ref => sub {
+                 my ($k,$v) = @_;
+                 # store lookup $k => $v
+         },
+         modify_records => {
+=> { '^a' => { ' : ' => '^b' } },
+=> { '*' => { '^b' => ' ; ' } },
+         },
   );
  By default, C<code_page> is assumed to be C<852>.
-Line 159 
 C<offset> is optional parametar to posit
+Line 180 
 C<offset> is optional parametar to posit
  C<limit> is optional parametar to read just C<limit> records from database
+ C<stats> create optional report about usage of fields and subfields
+ C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to
+ lookup.
+ C<modify_records> specify mapping from subfields to delimiters or from
+ delimiters to subfields, as well as oprations on fields (if subfield is
+ defined as C<*>.
  Returns size of database, regardless of C<offset> and C<limit>
  parametars, see also C<size>.
-Line 170 
 sub open {
+Line 200 
 sub open {
          my $log = $self->_get_logger();
+         $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
+         $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
+                 if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
          $log->logcroak("need path") if (! $arg->{'path'});
          my $code_page = $arg->{'code_page'} || '852';
-Line 180 
 sub open {
+Line 214 
 sub open {
          }
          # create Text::Iconv object
-         $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});
+         $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!
+         my $filter_ref;
+         my $recode_regex;
+         my $recode_map;
+         if ($self->{recode}) {
+                 my @r = split(/\s/, $self->{recode});
+                 if ($#r % 2 != 1) {
+                         $log->logwarn("recode needs even number of elements (some number of valid pairs)");
+                 } else {
+                         while (@r) {
+                                 my $from = shift @r;
+                                 my $to = shift @r;
+                                 $recode_map->{$from} = $to;
+                         }
+                         $recode_regex = join '|' => keys %{ $recode_map };
+                         $log->debug("using recode regex: $recode_regex");
+                 }
+         }
+         my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
+         $log->debug("rec_regex: ", Dumper($rec_regex));
          my ($db, $size) = $self->{open_db}->( $self,
                  path => $arg->{path},
+                 filter => sub {
+                                 my ($l,$f_nr) = @_;
+                                 return unless defined($l);
+                                 ## FIXME remove iconv!
+                                 $l = $self->{iconv}->convert($l) if ($self->{iconv});
+                                 $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
+                                 ## FIXME remove this warning when we are sure that none of API is calling
+                                 ## this wrongly
+                                 warn "filter called without field number" unless ($f_nr);
+                                 return $l unless ($rec_regex && $f_nr);
+                                 # apply regexps
+                                 if ($rec_regex && defined($rec_regex->{$f_nr})) {
+                                         $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
+                                         my $c = 0;
+                                         foreach my $r (@{ $rec_regex->{$f_nr} }) {
+                                                 while ( eval '$l =~ ' . $r ) { $c++ };
+                                         }
+                                         warn "## field $f_nr triggered $c regexpes\n" if ($c && $self->{debug});
+                                 }
+                                 return $l;
+                 },
+                 %{ $arg },
          );
-         unless ($db) {
+         unless (defined($db)) {
                  $log->logwarn("can't open database $arg->{path}, skipping...");
                  return;
          }
-Line 196 
 sub open {
+Line 283 
 sub open {
                  return;
          }
-         my $offset = 1;
+         my $from_rec = 1;
-         my $limit = $size;
+         my $to_rec = $size;
          if (my $s = $self->{offset}) {
-                 $log->info("skipping to MFN $s");
+                 $log->debug("skipping to MFN $s");
-                 $offset = $s;
+                 $from_rec = $s;
          } else {
-                 $self->{offset} = $offset;
+                 $self->{offset} = $from_rec;
          }
          if ($self->{limit}) {
                  $log->debug("limiting to ",$self->{limit}," records");
-                 $limit = $offset + $self->{limit} - 1;
+                 $to_rec = $from_rec + $self->{limit} - 1;
-                 $limit = $size if ($limit > $size);
+                 $to_rec = $size if ($to_rec > $size);
          }
          # store size for later
-         $self->{size} = ($limit - $offset) ? ($limit - $offset + 1) : 0;
+         $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
-         $log->info("processing $self->{size} records in $code_page, convert to $self->{code_page}");
+         $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
          # read database
-         for (my $pos = $offset; $pos <= $limit; $pos++) {
+         for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
                  $log->debug("position: $pos\n");
                  my $rec = $self->{fetch_rec}->($self, $db, $pos );
+                 $log->debug(sub { Dumper($rec) });
                  if (! $rec) {
                          $log->warn("record $pos empty? skipping...");
                          next;
-Line 237 
 sub open {
+Line 326 
 sub open {
                  }
                  # create lookup
-                 $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});
+                 $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
+                 # update counters for statistics
+                 if ($self->{stats}) {
+                         foreach my $fld (keys %{ $rec }) {
+                                 $self->{_stats}->{fld}->{ $fld }++;
-                 $self->progress_bar($pos,$limit);
+                                 $log->logdie("invalid record fild $fld, not ARRAY")
+                                         unless (ref($rec->{ $fld }) eq 'ARRAY');
+                                 foreach my $row (@{ $rec->{$fld} }) {
+                                         if (ref($row) eq 'HASH') {
+                                                 foreach my $sf (keys %{ $row }) {
+                                                         $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
+                                                         $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
+                                                                         if (ref($row->{$sf}) eq 'ARRAY');
+                                                 }
+                                         } else {
+                                                 $self->{_stats}->{repeatable}->{ $fld }++;
+                                         }
+                                 }
+                         }
+                 }
+                 $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
          }
-Line 247 
 sub open {
+Line 362 
 sub open {
          $self->{last_pcnt} = 0;
          # store max mfn and return it.
-         $self->{max_pos} = $limit;
+         $self->{max_pos} = $to_rec;
-         $log->debug("max_pos: $limit");
+         $log->debug("max_pos: $to_rec");
          return $size;
  }
-Line 285 
 sub fetch {
+Line 400 
 sub fetch {
                  return;
          }
-         $self->progress_bar($mfn,$self->{max_pos});
+         $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
          my $rec;
-Line 360 
 sub seek {
+Line 475 
 sub seek {
          return $self->{pos} = (($pos - 1) || -1);
  }
+ =head2 stats
+ Dump statistics about field and subfield usage
+   print $input->stats;
+ =cut
+ sub stats {
+         my $self = shift;
+         my $log = $self->_get_logger();
+         my $s = $self->{_stats};
+         if (! $s) {
+                 $log->warn("called stats, but there is no statistics collected");
+                 return;
+         }
+         my $max_fld = 0;
+         my $out = join("\n",
+                 map {
+                         my $f = $_ || die "no field";
+                         my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
+                         $max_fld = $v if ($v > $max_fld);
+                         my $o = sprintf("%4s %d ~", $f, $v);
+                         if (defined($s->{sf}->{$f})) {
+                                 map {
+                                         $o .= sprintf(" %s:%d%s", $_,
+                                                 $s->{sf}->{$f}->{$_}->{count},
+                                                 $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
+                                         );
+                                 } sort keys %{ $s->{sf}->{$f} };
+                         }
+                         if (my $v_r = $s->{repeatable}->{$f}) {
+                                 $o .= " ($v_r)" if ($v_r != $v);
+                         }
+                         $o;
+                 } sort { $a cmp $b } keys %{ $s->{fld} }
+         );
+         $log->debug( sub { Dumper($s) } );
+         return $out;
+ }
+ =head2 modify_record_regexps
+ Generate hash with regexpes to be applied using L<filter>.
+   my $regexpes = $input->modify_record_regexps(
+=> { '^a' => { ' : ' => '^b' } },
+=> { '*' => { '^b' => ' ; ' } },
+   );
+ =cut
+ sub modify_record_regexps {
+         my $self = shift;
+         my $modify_record = {@_};
+         my $regexpes;
+         foreach my $f (keys %$modify_record) {
+ warn "--- f: $f\n";
+                 foreach my $sf (keys %{ $modify_record->{$f} }) {
+ warn "---- sf: $sf\n";
+                         foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
+                                 my $to = $modify_record->{$f}->{$sf}->{$from};
+                                 #die "no field?" unless defined($to);
+ warn "----- transform: |$from| -> |$to|\n";
+                                 if ($sf =~ /^\^/) {
+                                         my $regex =
+                                                 's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
+                                         push @{ $regexpes->{$f} }, $regex;
+ warn ">>>>> $regex [sf]\n";
+                                 } else {
+                                         my $regex =
+                                                 's/\Q'. $from .'\E/'. $to .'/g';
+                                         push @{ $regexpes->{$f} }, $regex;
+ warn ">>>>> $regex [global]\n";
+                                 }
+                         }
+                 }
+         }
+         return $regexpes;
+ }
  =head1 MEMORY USAGE
-Line 398 
 Dobrica Pavlinusic, C<< <dpavlin@rot13.o
+Line 608 
 Dobrica Pavlinusic, C<< <dpavlin@rot13.o
  =head1 COPYRIGHT & LICENSE
- Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
+ Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
  This program is free software; you can redistribute it and/or modify it
  under the same terms as Perl itself.

 Legend:



Removed from v.307
 


changed lines


 
Added in v.599
 Legend:



Removed from v.307
 


changed lines


 
Added in v.599
-Removed from v.307
+Added in v.599

	ViewVC Help
Powered by ViewVC 1.1.26