/[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 3 by dpavlin,
Sat Jul 16 11:07:38 2005 UTC
+revision 634 by dpavlin,
Wed Sep  6 18:08:30 2006 UTC
 Line 3 
 package WebPAC::Input;
  use warnings;
  use strict;
+ use blib;
+ use WebPAC::Common;
+ use base qw/WebPAC::Common/;
+ use Data::Dumper;
+ use Encode qw/from_to/;
  =head1 NAME
- WebPAC::Input - core module for input file format
+ WebPAC::Input - read different file formats into WebPAC
  =head1 VERSION
- Version 0.01
+ Version 0.11
  =cut
- our $VERSION = '0.01';
+ our $VERSION = '0.11';
  =head1 SYNOPSIS
- This module will load particular loader module and execute it's functions.
+ This module implements input as database which have fixed and known
+ I<size> while indexing and single unique numeric identifier for database
+ position ranging from 1 to I<size>.
+ Simply, something that is indexed by unmber from 1 .. I<size>.
+ Examples of such databases are CDS/ISIS files, MARC files, lines in
+ text file, and so on.
+ Specific file formats are implemented using low-level interface modules,
+ located in C<WebPAC::Input::*> namespace which export C<open_db>,
+ C<fetch_rec> and optional C<init> functions.
  Perhaps a little code snippet.
-     use WebPAC::Input;
+         use WebPAC::Input;
+         my $db = WebPAC::Input->new(
+                 module => 'WebPAC::Input::ISIS',
+                 low_mem => 1,
+         );
+         $db->open( path => '/path/to/database' );
+         print "database size: ",$db->size,"\n";
+         while (my $rec = $db->fetch) {
+                 # do something with $rec
+         }
-     my $db = WebPAC::Input->new(
-         format => 'NULL',
-         config => $config,
-     );
-     $db->open('/path/to/database');
-     print "database size: ",$db->size,"\n";
-     while (my $row = $db->fetch) {
-         ...
-     }
-     $db->close;
  =head1 FUNCTIONS
-Line 41 
 Perhaps a little code snippet.
+Line 60 
 Perhaps a little code snippet.
  Create new input database object.
-   my $db = new WebPAC::Input( format => 'NULL' );
+   my $db = new WebPAC::Input(
+         module => 'WebPAC::Input::MARC',
+         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
+ L<WebPAC::Input::MARC>.
+ 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.
- This function will load needed wrapper module and
+ 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.
  =cut
  sub new {
          my $class = shift;
          my $self = {@_};
          bless($self, $class);
+         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;
+         $module .= '.pm';
+         $log->debug("require low-level module $self->{module} from $module");
+         require $module;
+         #eval $self->{module} .'->import';
+         # check if required subclasses are implemented
+         foreach my $subclass (qw/open_db fetch_rec init/) {
+                 my $n = $self->{module} . '::' . $subclass;
+                 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, @_);
+         }
+         $self->{'encoding'} ||= 'ISO-8859-2';
+         # running with low_mem flag? well, use DBM::Deep then.
+         if ($self->{'low_mem'}) {
+                 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
+                 my $db_file = "data.db";
+                 if (-e $db_file) {
+                         unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
+                         $log->debug("removed '$db_file' from last run");
+                 }
+                 require DBM::Deep;
+                 my $db = new DBM::Deep $db_file;
+                 $log->logdie("DBM::Deep error: $!") unless ($db);
+                 if ($db->error()) {
+                         $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
+                 } else {
+                         $log->debug("using file '$db_file' for DBM::Deep");
+                 }
+                 $self->{'db'} = $db;
+         }
          $self ? return $self : return undef;
  }
  =head2 open
+ This function will read whole database in memory and produce lookups.
+  $input->open(
+         path => '/path/to/database/file',
+         code_page => 'cp852',
+         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<cp852>.
+ C<offset> is optional parametar to position at some offset before reading from database.
+ 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>.
  =cut
  sub open {
+         my $self = shift;
+         my $arg = {@_};
+         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'} || 'cp852';
+         # store data in object
+         $self->{'input_code_page'} = $code_page;
+         foreach my $v (qw/path offset limit/) {
+                 $self->{$v} = $arg->{$v} if ($arg->{$v});
+         }
+         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);
+ #                       from_to($l, $code_page, $self->{'encoding'});
+ #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
+ #                       return $l;
+ #               },
+                 %{ $arg },
+         );
+         unless (defined($db)) {
+                 $log->logwarn("can't open database $arg->{path}, skipping...");
+                 return;
+         }
+         unless ($size) {
+                 $log->logwarn("no records in database $arg->{path}, skipping...");
+                 return;
+         }
+         my $from_rec = 1;
+         my $to_rec = $size;
+         if (my $s = $self->{offset}) {
+                 $log->debug("skipping to MFN $s");
+                 $from_rec = $s;
+         } else {
+                 $self->{offset} = $from_rec;
+         }
+         if ($self->{limit}) {
+                 $log->debug("limiting to ",$self->{limit}," records");
+                 $to_rec = $from_rec + $self->{limit} - 1;
+                 $to_rec = $size if ($to_rec > $size);
+         }
+         # store size for later
+         $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
+         $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
+         # read database
+         for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
+                 $log->debug("position: $pos\n");
+                 my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
+                                 my ($l,$f_nr) = @_;
+ #                               return unless defined($l);
+ #                               return $l unless ($rec_regex && $f_nr);
+                                 $log->debug("-=> $f_nr ## $l");
+                                 # codepage conversion and recode_regex
+                                 from_to($l, $code_page, $self->{'encoding'});
+                                 $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
+                                 # 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} }) {
+                                                 my $old_l = $l;
+                                                 eval '$l =~ ' . $r;
+                                                 if ($old_l ne $l) {
+                                                         $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
+                                                 }
+                                                 $log->error("error applying regex: $r") if ($@);
+                                         }
+                                 }
+                                 $log->debug("<=- $f_nr ## $l");
+                                 return $l;
+                 });
+                 $log->debug(sub { Dumper($rec) });
+                 if (! $rec) {
+                         $log->warn("record $pos empty? skipping...");
+                         next;
+                 }
+                 # store
+                 if ($self->{low_mem}) {
+                         $self->{db}->put($pos, $rec);
+                 } else {
+                         $self->{data}->{$pos} = $rec;
+                 }
+                 # create lookup
+                 $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
+                 # update counters for statistics
+                 if ($self->{stats}) {
+                         # fetch clean record with regexpes applied for statistics
+                         my $rec = $self->{fetch_rec}->($self, $db, $pos);
+                         foreach my $fld (keys %{ $rec }) {
+                                 $self->{_stats}->{fld}->{ $fld }++;
+                                 $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 }) {
+                                                         next if ($sf eq 'subfields');
+                                                         $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});
+         }
+         $self->{pos} = -1;
+         $self->{last_pcnt} = 0;
+         # store max mfn and return it.
+         $self->{max_pos} = $to_rec;
+         $log->debug("max_pos: $to_rec");
+         return $size;
  }
- =head2 function2
+ =head2 fetch
+ Fetch next record from database. It will also displays progress bar.
+  my $rec = $isis->fetch;
+ Record from this function should probably go to C<data_structure> for
+ normalisation.
  =cut
- sub function2 {
+ sub fetch {
+         my $self = shift;
+         my $log = $self->_get_logger();
+         $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
+         if ($self->{pos} == -1) {
+                 $self->{pos} = $self->{offset};
+         } else {
+                 $self->{pos}++;
+         }
+         my $mfn = $self->{pos};
+         if ($mfn > $self->{max_pos}) {
+                 $self->{pos} = $self->{max_pos};
+                 $log->debug("at EOF");
+                 return;
+         }
+         $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
+         my $rec;
+         if ($self->{low_mem}) {
+                 $rec = $self->{db}->get($mfn);
+         } else {
+                 $rec = $self->{data}->{$mfn};
+         }
+         $rec ||= 0E0;
  }
+ =head2 pos
+ Returns current record number (MFN).
+  print $isis->pos;
+ First record in database has position 1.
+ =cut
+ sub pos {
+         my $self = shift;
+         return $self->{pos};
+ }
+ =head2 size
+ Returns number of records in database
+  print $isis->size;
+ Result from this function can be used to loop through all records
+  foreach my $mfn ( 1 ... $isis->size ) { ... }
+ because it takes into account C<offset> and C<limit>.
+ =cut
+ sub size {
+         my $self = shift;
+         return $self->{size};
+ }
+ =head2 seek
+ Seek to specified MFN in file.
+  $isis->seek(42);
+ First record in database has position 1.
+ =cut
+ sub seek {
+         my $self = shift;
+         my $pos = shift || return;
+         my $log = $self->_get_logger();
+         if ($pos < 1) {
+                 $log->warn("seek before first record");
+                 $pos = 1;
+         } elsif ($pos > $self->{max_pos}) {
+                 $log->warn("seek beyond last record");
+                 $pos = $self->{max_pos};
+         }
+         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;
+         my $log = $self->_get_logger();
+         foreach my $f (keys %$modify_record) {
+                 $log->debug("field: $f");
+                 foreach my $sf (keys %{ $modify_record->{$f} }) {
+                         $log->debug("subfield: $sf");
+                         foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
+                                 my $to = $modify_record->{$f}->{$sf}->{$from};
+                                 #die "no field?" unless defined($to);
+                                 $log->debug("transform: |$from| -> |$to|");
+                                 if ($sf =~ /^\^/) {
+                                         my $regex =
+                                                 's/\Q'. $sf .'\E(.*?)\Q'. $from .'\E(.*?)/'. $sf .'$1'. $to .'$2/g';
+                                         push @{ $regexpes->{$f} }, $regex;
+                                         $log->debug(">>>>> $regex [sf]");
+                                 } else {
+                                         my $regex =
+                                                 's/\Q'. $from .'\E/'. $to .'/g';
+                                         push @{ $regexpes->{$f} }, $regex;
+                                         $log->debug(">>>>> $regex [global]");
+                                 }
+                         }
+                 }
+         }
+         return $regexpes;
+ }
  =head1 MEMORY USAGE
-Line 108 
 Dobrica Pavlinusic, C<< <dpavlin@rot13.o
+Line 620 
 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.3
 


changed lines


 
Added in v.634
 Legend:



Removed from v.3
 


changed lines


 
Added in v.634
-Removed from v.3
+Added in v.634

	ViewVC Help
Powered by ViewVC 1.1.26