/[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 339 by dpavlin, Sat Dec 31 16:50:11 2005 UTC revision 707 by dpavlin, Mon Sep 25 15:26:12 2006 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;
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 14  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.03  Version 0.13
20    
21  =cut  =cut
22    
23  our $VERSION = '0.03';  our $VERSION = '0.13';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 37  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,  
                 lookup => $lookup_obj,  
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
53            }
54    
55    
56    
# Line 61  Create new input database object. Line 62  Create new input database object.
62    
63    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
64          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
65          code_page => 'ISO-8859-2',          encoding => 'ISO-8859-2',
66          low_mem => 1,          low_mem => 1,
67            recode => 'char pairs',
68            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<code_page> specify application code page (which will be  Optional parametar C<encoding> specify application code page (which will be
75  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
76  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
77    
78  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
79    
80    C<recode> is optional string constisting of character or words pairs that
81    should be replaced in input stream.
82    
83    C<no_progress_bar> disables progress bar output on C<STDOUT>
84    
85  This function will also call low-level C<init> if it exists with same  This function will also call low-level C<init> if it exists with same
86  parametars.  parametars.
87    
# Line 86  sub new { Line 94  sub new {
94    
95          my $log = $self->_get_logger;          my $log = $self->_get_logger;
96    
97            $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
98            $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 = $self->{module};
102          $module =~ s#::#/#g;          $module =~ s#::#/#g;
# Line 96  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 111  sub new { Line 122  sub new {
122                  $self->{init}->($self, @_);                  $self->{init}->($self, @_);
123          }          }
124    
125          $self->{'code_page'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
126    
127          # running with low_mem flag? well, use DBM::Deep then.          # running with low_mem flag? well, use DBM::Deep then.
128          if ($self->{'low_mem'}) {          if ($self->{'low_mem'}) {
# Line 148  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,          stats => 1,
166            lookup_coderef => sub {
167                    my $rec = shift;
168                    # store lookups
169            },
170            modify_records => {
171                    900 => { '^a' => { ' : ' => '^b' } },
172                    901 => { '*' => { '^b' => ' ; ' } },
173            },
174            modify_file => 'conf/modify/mapping.map',
175   );   );
176    
177  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
178    
179  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.
180    
181  C<limit> is optional parametar to read just C<limit> records from database  C<limit> is optional parametar to read just C<limit> records from database
182    
183    C<stats> create optional report about usage of fields and subfields
184    
185    C<lookup_coderef> is closure to called to save data into lookups
186    
187    C<modify_records> specify mapping from subfields to delimiters or from
188    delimiters to subfields, as well as oprations on fields (if subfield is
189    defined as C<*>.
190    
191    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
192    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
193    overrides C<modify_records> if both exists for same input.
194    
195  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
196  parametars, see also C<size>.  parametars, see also C<size>.
197    
# Line 171  sub open { Line 203  sub open {
203    
204          my $log = $self->_get_logger();          my $log = $self->_get_logger();
205    
206            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
207            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
208                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
209    
210            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
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 180  sub open { Line 218  sub open {
218                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
219          }          }
220    
221          # create Text::Iconv object          my $filter_ref;
222          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          my $recode_regex;
223            my $recode_map;
224    
225            if ($self->{recode}) {
226                    my @r = split(/\s/, $self->{recode});
227                    if ($#r % 2 != 1) {
228                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
229                    } else {
230                            while (@r) {
231                                    my $from = shift @r;
232                                    my $to = shift @r;
233                                    $recode_map->{$from} = $to;
234                            }
235    
236                            $recode_regex = join '|' => keys %{ $recode_map };
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 => 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 },
263          );          );
264    
265          unless ($db) {          unless (defined($db)) {
266                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
267                  return;                  return;
268          }          }
# Line 201  sub open { Line 276  sub open {
276          my $to_rec = $size;          my $to_rec = $size;
277    
278          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
279                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
280                  $from_rec = $s;                  $from_rec = $s;
281          } else {          } else {
282                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec;
# Line 216  sub open { Line 291  sub open {
291          # store size for later          # store size for later
292          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
293    
294          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}");          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
295    
296          # read database          # read database
297          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
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 240  sub open { Line 342  sub open {
342                  }                  }
343    
344                  # create lookup                  # create lookup
345                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
346    
347                    # update counters for statistics
348                    if ($self->{stats}) {
349    
350                            # fetch clean record with regexpes applied for statistics
351                            my $rec = $self->{fetch_rec}->($self, $pos);
352    
353                  $self->progress_bar($pos,$to_rec);                          foreach my $fld (keys %{ $rec }) {
354                                    $self->{_stats}->{fld}->{ $fld }++;
355    
356                                    $log->logdie("invalid record fild $fld, not ARRAY")
357                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
358            
359                                    foreach my $row (@{ $rec->{$fld} }) {
360    
361                                            if (ref($row) eq 'HASH') {
362    
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    
370                                            } else {
371                                                    $self->{_stats}->{repeatable}->{ $fld }++;
372                                            }
373                                    }
374                            }
375                    }
376    
377                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
378    
379          }          }
380    
# Line 288  sub fetch { Line 420  sub fetch {
420                  return;                  return;
421          }          }
422    
423          $self->progress_bar($mfn,$self->{max_pos});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
424    
425          my $rec;          my $rec;
426    
# Line 363  sub seek { Line 495  sub seek {
495          return $self->{pos} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
496  }  }
497    
498    =head2 stats
499    
500    Dump statistics about field and subfield usage
501    
502      print $input->stats;
503    
504    =cut
505    
506    sub stats {
507            my $self = shift;
508    
509            my $log = $self->_get_logger();
510    
511            my $s = $self->{_stats};
512            if (! $s) {
513                    $log->warn("called stats, but there is no statistics collected");
514                    return;
515            }
516    
517            my $max_fld = 0;
518    
519            my $out = join("\n",
520                    map {
521                            my $f = $_ || die "no field";
522                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
523                            $max_fld = $v if ($v > $max_fld);
524    
525                            my $o = sprintf("%4s %d ~", $f, $v);
526    
527                            if (defined($s->{sf}->{$f})) {
528                                    map {
529                                            $o .= sprintf(" %s:%d%s", $_,
530                                                    $s->{sf}->{$f}->{$_}->{count},
531                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
532                                            );
533                                    } sort keys %{ $s->{sf}->{$f} };
534                            }
535    
536                            if (my $v_r = $s->{repeatable}->{$f}) {
537                                    $o .= " ($v_r)" if ($v_r != $v);
538                            }
539    
540                            $o;
541                    } sort { $a cmp $b } keys %{ $s->{fld} }
542            );
543    
544            $log->debug( sub { Dumper($s) } );
545    
546            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    
# Line 401  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.339  
changed lines
  Added in v.707
  ViewVC Help
Powered by ViewVC 1.1.26