/[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 10 by dpavlin, Sat Jul 16 20:35:30 2005 UTC revision 624 by dpavlin, Sat Aug 26 12:00:31 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;
9    use base qw/WebPAC::Common/;
10    use Data::Dumper;
11    use Encode qw/from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
15  WebPAC::Input - core module for input file format  WebPAC::Input - read different file formats into WebPAC
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.01  Version 0.11
20    
21  =cut  =cut
22    
23  our $VERSION = '0.01';  our $VERSION = '0.11';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
27  This module will load particular loader module and execute it's functions.  This module implements input as database which have fixed and known
28    I<size> while indexing and single unique numeric identifier for database
29    position ranging from 1 to I<size>.
30    
31    Simply, something that is indexed by unmber from 1 .. I<size>.
32    
33    Examples of such databases are CDS/ISIS files, MARC files, lines in
34    text file, and so on.
35    
36    Specific file formats are implemented using low-level interface modules,
37    located in C<WebPAC::Input::*> namespace which export C<open_db>,
38    C<fetch_rec> and optional C<init> functions.
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(
45                    module => 'WebPAC::Input::ISIS',
46                    low_mem => 1,
47            );
48    
49            $db->open( path => '/path/to/database' );
50            print "database size: ",$db->size,"\n";
51            while (my $rec = $db->fetch) {
52                    # do something with $rec
53            }
54    
     my $db = WebPAC::Input->new(  
         format => 'NULL',  
         config => $config,  
         lookup => $lookup_obj,  
         low_mem => 1,  
     );  
55    
     $db->open('/path/to/database');  
     print "database size: ",$db->size,"\n";  
     while (my $row = $db->fetch) {  
         ...  
     }  
     $db->close;  
56    
57  =head1 FUNCTIONS  =head1 FUNCTIONS
58    
# Line 44  Perhaps a little code snippet. Line 61  Perhaps a little code snippet.
61  Create new input database object.  Create new input database object.
62    
63    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
64          format => 'NULL'          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  Optional parametar C<code_page> specify application code page (which will be  C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
72    L<WebPAC::Input::MARC>.
73    
74    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
86    parametars.
87    
88  =cut  =cut
89    
90  sub new {  sub new {
91          my $class = shift;          my $class = shift;
92          my $self = {@_};          my $self = {@_};
93          bless($self, $class);          bless($self, $class);
94    
         $self->{'code_page'} ||= 'ISO-8859-2';  
   
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});
101            my $module = $self->{module};
102            $module =~ s#::#/#g;
103            $module .= '.pm';
104            $log->debug("require low-level module $self->{module} from $module");
105    
106            require $module;
107            #eval $self->{module} .'->import';
108    
109            # check if required subclasses are implemented
110            foreach my $subclass (qw/open_db fetch_rec init/) {
111                    my $n = $self->{module} . '::' . $subclass;
112                    if (! defined &{ $n }) {
113                            my $missing = "missing $subclass in $self->{module}";
114                            $self->{$subclass} = sub { $log->logwarn($missing) };
115                    } else {
116                            $self->{$subclass} = \&{ $n };
117                    }
118            }
119    
120            if ($self->{init}) {
121                    $log->debug("calling init");
122                    $self->{init}->($self, @_);
123            }
124    
125            $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'}) {
129                  $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");                  $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
# Line 95  sub new { Line 153  sub new {
153          $self ? return $self : return undef;          $self ? return $self : return undef;
154  }  }
155    
156    =head2 open
157    
158    This function will read whole database in memory and produce lookups.
159    
160     $input->open(
161            path => '/path/to/database/file',
162            code_page => 'cp852',
163            limit => 500,
164            offset => 6000,
165            lookup => $lookup_obj,
166            stats => 1,
167            lookup_ref => sub {
168                    my ($k,$v) = @_;
169                    # store lookup $k => $v
170            },
171            modify_records => {
172                    900 => { '^a' => { ' : ' => '^b' } },
173                    901 => { '*' => { '^b' => ' ; ' } },
174            },
175     );
176    
177    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.
180    
181    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 call when adding C<< key => 'value' >> combinations to
186    lookup.
187    
188    C<modify_records> specify mapping from subfields to delimiters or from
189    delimiters to subfields, as well as oprations on fields (if subfield is
190    defined as C<*>.
191    
192    Returns size of database, regardless of C<offset> and C<limit>
193    parametars, see also C<size>.
194    
195    =cut
196    
197    sub open {
198            my $self = shift;
199            my $arg = {@_};
200    
201            my $log = $self->_get_logger();
202    
203            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
204            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
205                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
206    
207            $log->logcroak("need path") if (! $arg->{'path'});
208            my $code_page = $arg->{'code_page'} || 'cp852';
209    
210            # store data in object
211            $self->{'input_code_page'} = $code_page;
212            foreach my $v (qw/path offset limit/) {
213                    $self->{$v} = $arg->{$v} if ($arg->{$v});
214            }
215    
216            my $filter_ref;
217            my $recode_regex;
218            my $recode_map;
219    
220            if ($self->{recode}) {
221                    my @r = split(/\s/, $self->{recode});
222                    if ($#r % 2 != 1) {
223                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
224                    } else {
225                            while (@r) {
226                                    my $from = shift @r;
227                                    my $to = shift @r;
228                                    $recode_map->{$from} = $to;
229                            }
230    
231                            $recode_regex = join '|' => keys %{ $recode_map };
232    
233                            $log->debug("using recode regex: $recode_regex");
234                    }
235    
236            }
237    
238            my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
239            $log->debug("rec_regex: ", Dumper($rec_regex));
240    
241            my ($db, $size) = $self->{open_db}->( $self,
242                    path => $arg->{path},
243    #               filter => sub {
244    #                       my ($l,$f_nr) = @_;
245    #                       return unless defined($l);
246    #                       from_to($l, $code_page, $self->{'encoding'});
247    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
248    #                       return $l;
249    #               },
250                    %{ $arg },
251            );
252    
253            unless (defined($db)) {
254                    $log->logwarn("can't open database $arg->{path}, skipping...");
255                    return;
256            }
257    
258            unless ($size) {
259                    $log->logwarn("no records in database $arg->{path}, skipping...");
260                    return;
261            }
262    
263            my $from_rec = 1;
264            my $to_rec = $size;
265    
266            if (my $s = $self->{offset}) {
267                    $log->debug("skipping to MFN $s");
268                    $from_rec = $s;
269            } else {
270                    $self->{offset} = $from_rec;
271            }
272    
273            if ($self->{limit}) {
274                    $log->debug("limiting to ",$self->{limit}," records");
275                    $to_rec = $from_rec + $self->{limit} - 1;
276                    $to_rec = $size if ($to_rec > $size);
277            }
278    
279            # store size for later
280            $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
281    
282            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
283    
284            # read database
285            for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
286    
287                    $log->debug("position: $pos\n");
288    
289                    my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
290                                    my ($l,$f_nr) = @_;
291    #                               return unless defined($l);
292    #                               return $l unless ($rec_regex && $f_nr);
293    
294    warn "## --> $f_nr ## $l\n";
295                                    # codepage conversion and recode_regex
296    #                               from_to($l, $code_page, $self->{'encoding'});
297                                    from_to($l, $code_page, 'utf-8');
298                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
299    
300                                    # apply regexps
301                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
302                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
303                                            my $c = 0;
304                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
305                                                    #$log->debug("\$l = $l\neval \$l =~ $r");
306                                                    eval '$l =~ ' . $r;
307                                                    $log->error("error applying regex: $r") if ($@);
308                                            }
309                                    }
310    
311    warn "## <-- $f_nr ## $l\n";
312                                    return $l;
313                    });
314    
315                    $log->debug(sub { Dumper($rec) });
316    
317                    if (! $rec) {
318                            $log->warn("record $pos empty? skipping...");
319                            next;
320                    }
321    
322                    # store
323                    if ($self->{low_mem}) {
324                            $self->{db}->put($pos, $rec);
325                    } else {
326                            $self->{data}->{$pos} = $rec;
327                    }
328    
329                    # create lookup
330                    $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
331    
332                    # update counters for statistics
333                    if ($self->{stats}) {
334    
335                            # fetch clean record with regexpes applied for statistics
336                            my $rec = $self->{fetch_rec}->($self, $db, $pos);
337    
338                            foreach my $fld (keys %{ $rec }) {
339                                    $self->{_stats}->{fld}->{ $fld }++;
340    
341                                    $log->logdie("invalid record fild $fld, not ARRAY")
342                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
343            
344                                    foreach my $row (@{ $rec->{$fld} }) {
345    
346                                            if (ref($row) eq 'HASH') {
347    
348                                                    foreach my $sf (keys %{ $row }) {
349                                                            next if ($sf eq 'subfields');
350                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
351                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
352                                                                            if (ref($row->{$sf}) eq 'ARRAY');
353                                                    }
354    
355                                            } else {
356                                                    $self->{_stats}->{repeatable}->{ $fld }++;
357                                            }
358                                    }
359                            }
360                    }
361    
362                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
363    
364            }
365    
366            $self->{pos} = -1;
367            $self->{last_pcnt} = 0;
368    
369            # store max mfn and return it.
370            $self->{max_pos} = $to_rec;
371            $log->debug("max_pos: $to_rec");
372    
373            return $size;
374    }
375    
376    =head2 fetch
377    
378    Fetch next record from database. It will also displays progress bar.
379    
380     my $rec = $isis->fetch;
381    
382    Record from this function should probably go to C<data_structure> for
383    normalisation.
384    
385    =cut
386    
387    sub fetch {
388            my $self = shift;
389    
390            my $log = $self->_get_logger();
391    
392            $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
393    
394            if ($self->{pos} == -1) {
395                    $self->{pos} = $self->{offset};
396            } else {
397                    $self->{pos}++;
398            }
399    
400            my $mfn = $self->{pos};
401    
402            if ($mfn > $self->{max_pos}) {
403                    $self->{pos} = $self->{max_pos};
404                    $log->debug("at EOF");
405                    return;
406            }
407    
408            $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
409    
410            my $rec;
411    
412            if ($self->{low_mem}) {
413                    $rec = $self->{db}->get($mfn);
414            } else {
415                    $rec = $self->{data}->{$mfn};
416            }
417    
418            $rec ||= 0E0;
419    }
420    
421    =head2 pos
422    
423    Returns current record number (MFN).
424    
425     print $isis->pos;
426    
427    First record in database has position 1.
428    
429    =cut
430    
431    sub pos {
432            my $self = shift;
433            return $self->{pos};
434    }
435    
436    
437    =head2 size
438    
439    Returns number of records in database
440    
441     print $isis->size;
442    
443    Result from this function can be used to loop through all records
444    
445     foreach my $mfn ( 1 ... $isis->size ) { ... }
446    
447    because it takes into account C<offset> and C<limit>.
448    
449    =cut
450    
451    sub size {
452            my $self = shift;
453            return $self->{size};
454    }
455    
456    =head2 seek
457    
458    Seek to specified MFN in file.
459    
460     $isis->seek(42);
461    
462    First record in database has position 1.
463    
464    =cut
465    
466    sub seek {
467            my $self = shift;
468            my $pos = shift || return;
469    
470            my $log = $self->_get_logger();
471    
472            if ($pos < 1) {
473                    $log->warn("seek before first record");
474                    $pos = 1;
475            } elsif ($pos > $self->{max_pos}) {
476                    $log->warn("seek beyond last record");
477                    $pos = $self->{max_pos};
478            }
479    
480            return $self->{pos} = (($pos - 1) || -1);
481    }
482    
483    =head2 stats
484    
485    Dump statistics about field and subfield usage
486    
487      print $input->stats;
488    
489    =cut
490    
491    sub stats {
492            my $self = shift;
493    
494            my $log = $self->_get_logger();
495    
496            my $s = $self->{_stats};
497            if (! $s) {
498                    $log->warn("called stats, but there is no statistics collected");
499                    return;
500            }
501    
502            my $max_fld = 0;
503    
504            my $out = join("\n",
505                    map {
506                            my $f = $_ || die "no field";
507                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
508                            $max_fld = $v if ($v > $max_fld);
509    
510                            my $o = sprintf("%4s %d ~", $f, $v);
511    
512                            if (defined($s->{sf}->{$f})) {
513                                    map {
514                                            $o .= sprintf(" %s:%d%s", $_,
515                                                    $s->{sf}->{$f}->{$_}->{count},
516                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
517                                            );
518                                    } sort keys %{ $s->{sf}->{$f} };
519                            }
520    
521                            if (my $v_r = $s->{repeatable}->{$f}) {
522                                    $o .= " ($v_r)" if ($v_r != $v);
523                            }
524    
525                            $o;
526                    } sort { $a cmp $b } keys %{ $s->{fld} }
527            );
528    
529            $log->debug( sub { Dumper($s) } );
530    
531            return $out;
532    }
533    
534    =head2 modify_record_regexps
535    
536    Generate hash with regexpes to be applied using L<filter>.
537    
538      my $regexpes = $input->modify_record_regexps(
539                    900 => { '^a' => { ' : ' => '^b' } },
540                    901 => { '*' => { '^b' => ' ; ' } },
541      );
542    
543    =cut
544    
545    sub modify_record_regexps {
546            my $self = shift;
547            my $modify_record = {@_};
548    
549            my $regexpes;
550    
551            foreach my $f (keys %$modify_record) {
552    warn "--- f: $f\n";
553                    foreach my $sf (keys %{ $modify_record->{$f} }) {
554    warn "---- sf: $sf\n";
555                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
556                                    my $to = $modify_record->{$f}->{$sf}->{$from};
557                                    #die "no field?" unless defined($to);
558    warn "----- transform: |$from| -> |$to|\n";
559    
560                                    if ($sf =~ /^\^/) {
561                                            my $regex =
562                                                    's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
563                                            push @{ $regexpes->{$f} }, $regex;
564    warn ">>>>> $regex [sf]\n";
565                                    } else {
566                                            my $regex =
567                                                    's/\Q'. $from .'\E/'. $to .'/g';
568                                            push @{ $regexpes->{$f} }, $regex;
569    warn ">>>>> $regex [global]\n";
570                                    }
571    
572                            }
573                    }
574            }
575    
576            return $regexpes;
577    }
578    
579  =head1 MEMORY USAGE  =head1 MEMORY USAGE
580    
581  C<low_mem> options is double-edged sword. If enabled, WebPAC  C<low_mem> options is double-edged sword. If enabled, WebPAC
# Line 132  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 613  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
613    
614  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
615    
616  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
617    
618  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
619  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.10  
changed lines
  Added in v.624
  ViewVC Help
Powered by ViewVC 1.1.26