/[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 868 by dpavlin, Thu Jun 21 21:26:17 2007 UTC revision 1221 by dpavlin, Tue Jun 9 21:37:32 2009 UTC
# Line 3  package WebPAC::Input; Line 3  package WebPAC::Input;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6  use blib;  use lib 'lib';
7    
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Data::Dump qw/dump/;  use Data::Dump qw/dump/;
11  use Encode qw/from_to/;  use Encode qw/decode from_to/;
12    use YAML;
13    
14  =head1 NAME  =head1 NAME
15    
16  WebPAC::Input - read different file formats into WebPAC  WebPAC::Input - read different file formats into WebPAC
17    
 =head1 VERSION  
   
 Version 0.18  
   
18  =cut  =cut
19    
20  our $VERSION = '0.18';  our $VERSION = '0.19';
21    
22  =head1 SYNOPSIS  =head1 SYNOPSIS
23    
# Line 61  Create new input database object. Line 58  Create new input database object.
58    
59    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
60          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
         encoding => 'ISO-8859-2',  
61          recode => 'char pairs',          recode => 'char pairs',
62          no_progress_bar => 1,          no_progress_bar => 1,
63          input_config => {          input_config => {
# Line 72  Create new input database object. Line 68  Create new input database object.
68  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
69  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
70    
 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>.  
   
71  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
72  should be replaced in input stream.  should be replaced in input stream.
73    
# Line 93  sub new { Line 85  sub new {
85    
86          my $log = $self->_get_logger;          my $log = $self->_get_logger;
87    
88          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});          $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
89          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});          $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
90          $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if ($self->{low_mem});          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if $self->{lookup};
91            $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if $self->{low_mem};
92    
93          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
94          my $module_path = $self->{module};          my $module_path = $self->{module};
# Line 105  sub new { Line 98  sub new {
98    
99          require $module_path;          require $module_path;
100    
         $self->{'encoding'} ||= 'ISO-8859-2';  
   
101          $self ? return $self : return undef;          $self ? return $self : return undef;
102  }  }
103    
# Line 118  This function will read whole database i Line 109  This function will read whole database i
109    
110   $input->open(   $input->open(
111          path => '/path/to/database/file',          path => '/path/to/database/file',
112          code_page => 'cp852',          input_encoding => 'cp852',
113            strict_encoding => 0,
114          limit => 500,          limit => 500,
115          offset => 6000,          offset => 6000,
116          stats => 1,          stats => 1,
# Line 143  This function will read whole database i Line 135  This function will read whole database i
135    
136   );   );
137    
138  By default, C<code_page> is assumed to be C<cp852>.  By default, C<input_encoding> is assumed to be C<cp852>.
139    
140  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.
141    
# Line 164  overrides C<modify_records> if both exis Line 156  overrides C<modify_records> if both exis
156  C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention  C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
157  is documented in example above.  is documented in example above.
158    
159    C<strict_encoding> should really default to 1, but it doesn't for now.
160    
161  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
162  parametars, see also C<size>.  parametars, see also C<size>.
163    
# Line 174  sub open { Line 168  sub open {
168          my $arg = {@_};          my $arg = {@_};
169    
170          my $log = $self->_get_logger();          my $log = $self->_get_logger();
171            $log->debug( "arguments: ",dump( $arg ));
172    
173            $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
174            $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
175          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
176          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
177                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
# Line 182  sub open { Line 179  sub open {
179          $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");          $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
180    
181          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
182          my $code_page = $arg->{'code_page'} || 'cp852';          my $input_encoding = $arg->{'input_encoding'} || $self->{'input_encoding'} || 'cp852';
183    
184          # store data in object          # store data in object
         $self->{'input_code_page'} = $code_page;  
185          foreach my $v (qw/path offset limit/) {          foreach my $v (qw/path offset limit/) {
186                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
187          }          }
# Line 236  sub open { Line 232  sub open {
232    
233          my $ll_db = $class->new(          my $ll_db = $class->new(
234                  path => $arg->{path},                  path => $arg->{path},
235                  input_config => $arg->{input_config},                  input_config => $arg->{input_config} || $self->{input_config},
236  #               filter => sub {  #               filter => sub {
237  #                       my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
238  #                       return unless defined($l);  #                       return unless defined($l);
239  #                       from_to($l, $code_page, $self->{'encoding'});  #                       $l = decode($input_encoding, $l);
240  #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);  #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
241  #                       return $l;  #                       return $l;
242  #               },  #               },
# Line 278  sub open { Line 274  sub open {
274          # store size for later          # store size for later
275          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
276    
277          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');          my $strict_encoding = $arg->{strict_encoding} || $self->{strict_encoding}; ## FIXME should be 1 really
278    
279            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec]",
280                    " encoding $input_encoding ", $strict_encoding ? ' [strict]' : '',
281                    $self->{stats} ? ' [stats]' : '',
282            );
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++) {
# Line 296  sub open { Line 297  sub open {
297                                  $log->debug("-=> $f_nr ## $l");                                  $log->debug("-=> $f_nr ## $l");
298    
299                                  # codepage conversion and recode_regex                                  # codepage conversion and recode_regex
300                                  from_to($l, $code_page, $self->{'encoding'});                                  $l = decode($input_encoding, $l, 1);
301                                  $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);                                  $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
302    
303                                  # apply regexps                                  # apply regexps
# Line 315  sub open { Line 316  sub open {
316                                                          warn "*** $d\n" if ($debug);                                                          warn "*** $d\n" if ($debug);
317    
318                                                  }                                                  }
319                                                  $log->error("error applying regex: $r") if ($@);                                                  $log->error("error applying regex: ",dump($r), $@) if $@;
320                                          }                                          }
321                                  }                                  }
322    
# Line 353  sub open { Line 354  sub open {
354                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
355                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
356    
357                                  $log->logdie("invalid record fild $fld, not ARRAY")                                  #$log->logdie("invalid record fild $fld, not ARRAY")
358                                          unless (ref($rec->{ $fld }) eq 'ARRAY');                                  next unless (ref($rec->{ $fld }) eq 'ARRAY');
359                    
360                                  foreach my $row (@{ $rec->{$fld} }) {                                  foreach my $row (@{ $rec->{$fld} }) {
361    
# Line 391  sub open { Line 392  sub open {
392          return $size;          return $size;
393  }  }
394    
395    sub input_module { $_[0]->{ll_db} }
396    
397  =head2 fetch  =head2 fetch
398    
399  Fetch next record from database. It will also displays progress bar.  Fetch next record from database. It will also displays progress bar.
# Line 531  sub stats { Line 534  sub stats {
534                          my $o = sprintf("%4s %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
535    
536                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
537                                    my @subfields = keys %{ $s->{sf}->{$f} };
538                                  map {                                  map {
539                                          $o .= sprintf(" %s:%d%s", $_,                                          $o .= sprintf(" %s:%d%s", $_,
540                                                  $s->{sf}->{$f}->{$_}->{count},                                                  $s->{sf}->{$f}->{$_}->{count},
541                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
542                                          );                                          );
543                                  } sort keys %{ $s->{sf}->{$f} };                                  } (
544                                            # first indicators and other special subfields
545                                            sort( grep { length($_)  > 1 } @subfields ),
546                                            # then subfileds (single char)
547                                            sort( grep { length($_) == 1 } @subfields ),
548                                    );
549                          }                          }
550    
551                          if (my $v_r = $s->{repeatable}->{$f}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 544  sub stats { Line 553  sub stats {
553                          }                          }
554    
555                          $o;                          $o;
556                  } sort { $a <=> $b } keys %{ $s->{fld} }                  } sort {
557                            if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
558                                    $a <=> $b
559                            } else {
560                                    $a cmp $b
561                            }
562                    } keys %{ $s->{fld} }
563          );          );
564    
565          $log->debug( sub { dump($s) } );          $log->debug( sub { dump($s) } );
566    
567            my $path = 'var/stats.yml';
568            YAML::DumpFile( $path, $s );
569            $log->info( 'created ', $path, ' with ', -s $path, ' bytes' );
570    
571          return $out;          return $out;
572  }  }
573    
# Line 707  sub modify_file_regexps { Line 726  sub modify_file_regexps {
726                                  line => $.,                                  line => $.,
727                          };                          };
728                          $log->debug("regex: $regex");                          $log->debug("regex: $regex");
729                    } else {
730                            die "can't parse: $_";
731                  }                  }
732          }          }
733    
Legend:
Removed from v.868  
changed lines
  Added in v.1221
  ViewVC Help
Powered by ViewVC 1.1.26