/[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 652 by dpavlin, Thu Sep 7 15:01:45 2006 UTC revision 757 by dpavlin, Tue Oct 10 10:57:59 2006 UTC
# 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.12  Version 0.13
20    
21  =cut  =cut
22    
23  our $VERSION = '0.12';  our $VERSION = '0.13';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 98  sub new { Line 98  sub new {
98          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});          $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 dump_rec/) {          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->{'encoding'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
# Line 162  This function will read whole database i Line 150  This function will read whole database i
150          code_page => 'cp852',          code_page => 'cp852',
151          limit => 500,          limit => 500,
152          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
153          stats => 1,          stats => 1,
154          lookup_ref => sub {          lookup_coderef => sub {
155                  my ($k,$v) = @_;                  my $rec = shift;
156                  # store lookup $k => $v                  # store lookups
157          },          },
158          modify_records => {          modify_records => {
159                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
# Line 183  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 call when adding C<< key => 'value' >> combinations to  C<lookup_coderef> is closure to called to save data into lookups
 lookup.  
174    
175  C<modify_records> specify mapping from subfields to delimiters or from  C<modify_records> specify mapping from subfields to delimiters or from
176  delimiters to subfields, as well as oprations on fields (if subfield is  delimiters to subfields, as well as oprations on fields (if subfield is
# Line 209  sub open { Line 195  sub open {
195          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
196                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  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'} || 'cp852';          my $code_page = $arg->{'code_page'} || 'cp852';
202    
# Line 250  sub open { Line 238  sub open {
238          }          }
239          $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);          $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
240    
241          my ($db, $size) = $self->{open_db}->( $self,          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 => sub {  #               filter => sub {
246  #                       my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
# Line 262  sub open { Line 252  sub open {
252                  %{ $arg },                  %{ $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 298  sub open { Line 290  sub open {
290    
291                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
292    
293                  my $rec = $self->{fetch_rec}->($self, $pos, sub {                  my $rec = $ll_db->fetch_rec($pos, sub {
294                                  my ($l,$f_nr) = @_;                                  my ($l,$f_nr) = @_;
295  #                               return unless defined($l);  #                               return unless defined($l);
296  #                               return $l unless ($rec_regex && $f_nr);  #                               return $l unless ($rec_regex && $f_nr);
# Line 348  sub open { Line 340  sub open {
340                  if ($self->{stats}) {                  if ($self->{stats}) {
341    
342                          # fetch clean record with regexpes applied for statistics                          # fetch clean record with regexpes applied for statistics
343                          my $rec = $self->{fetch_rec}->($self, $pos);                          my $rec = $ll_db->fetch_rec($pos);
344    
345                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
346                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
# Line 385  sub open { Line 377  sub open {
377          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
378          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
379    
380            # save for dump
381            $self->{ll_db} = $ll_db;
382    
383          return $size;          return $size;
384  }  }
385    
# Line 555  Display humanly readable dump of record Line 550  Display humanly readable dump of record
550  sub dump {  sub dump {
551          my $self = shift;          my $self = shift;
552    
553          return $self->{dump_rec}->($self, $self->{pos});          return $self->{ll_db}->dump_rec( $self->{pos} );
554    
555  }  }
556    
# Line 640  sub modify_file_regexps { Line 635  sub modify_file_regexps {
635    
636          my $regexpes;          my $regexpes;
637    
638          CORE::open(my $fh, $modify_path) || $log->die("can't open modify file $modify_path: $!");          CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
639    
640          my ($f,$sf);          my ($f,$sf);
641    
Legend:
Removed from v.652  
changed lines
  Added in v.757
  ViewVC Help
Powered by ViewVC 1.1.26