9 use base qw/WebPAC::Common/;
11 use Encode qw/from_to/;
15 WebPAC::Input - read different file formats into WebPAC
23 our $VERSION = '0.13';
27 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>.
31 Simply, something that is indexed by unmber from 1 .. I<size>.
33 Examples of such databases are CDS/ISIS files, MARC files, lines in
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.
40 Perhaps a little code snippet.
44 my $db = WebPAC::Input->new(
45 module => 'WebPAC::Input::ISIS',
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
61 Create new input database object.
63 my $db = new WebPAC::Input(
64 module => 'WebPAC::Input::MARC',
65 encoding => 'ISO-8859-2',
67 recode => 'char pairs',
71 C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
72 L<WebPAC::Input::MARC>.
74 Optional parametar C<encoding> specify application code page (which will be
75 used internally). This should probably be your terminal encoding, and by
76 default, it C<ISO-8859-2>.
78 Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
80 C<recode> is optional string constisting of character or words pairs that
81 should be replaced in input stream.
83 C<no_progress_bar> disables progress bar output on C<STDOUT>
85 This function will also call low-level C<init> if it exists with same
95 my $log = $self->_get_logger;
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});
100 $log->logconfess("specify low-level file format module") unless ($self->{module});
101 my $module_path = $self->{module};
102 $module_path =~ s#::#/#g;
103 $module_path .= '.pm';
104 $log->debug("require low-level module $self->{module} from $module_path");
106 require $module_path;
108 # check if required subclasses are implemented
109 foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
113 $self->{'encoding'} ||= 'ISO-8859-2';
115 # running with low_mem flag? well, use DBM::Deep then.
116 if ($self->{'low_mem'}) {
117 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
119 my $db_file = "data.db";
122 unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
123 $log->debug("removed '$db_file' from last run");
128 my $db = new DBM::Deep $db_file;
130 $log->logdie("DBM::Deep error: $!") unless ($db);
133 $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
135 $log->debug("using file '$db_file' for DBM::Deep");
141 $self ? return $self : return undef;
146 This function will read whole database in memory and produce lookups.
149 path => '/path/to/database/file',
150 code_page => 'cp852',
154 lookup_coderef => sub {
159 900 => { '^a' => { ' : ' => '^b' } },
160 901 => { '*' => { '^b' => ' ; ' } },
162 modify_file => 'conf/modify/mapping.map',
165 By default, C<code_page> is assumed to be C<cp852>.
167 C<offset> is optional parametar to position at some offset before reading from database.
169 C<limit> is optional parametar to read just C<limit> records from database
171 C<stats> create optional report about usage of fields and subfields
173 C<lookup_coderef> is closure to called to save data into lookups
175 C<modify_records> specify mapping from subfields to delimiters or from
176 delimiters to subfields, as well as oprations on fields (if subfield is
179 C<modify_file> is alternative for C<modify_records> above which preserves order and offers
180 (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
181 overrides C<modify_records> if both exists for same input.
183 Returns size of database, regardless of C<offset> and C<limit>
184 parametars, see also C<size>.
192 my $log = $self->_get_logger();
194 $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
195 $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
196 if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
198 $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
200 $log->logcroak("need path") if (! $arg->{'path'});
201 my $code_page = $arg->{'code_page'} || 'cp852';
203 # store data in object
204 $self->{'input_code_page'} = $code_page;
205 foreach my $v (qw/path offset limit/) {
206 $self->{$v} = $arg->{$v} if ($arg->{$v});
213 if ($self->{recode}) {
214 my @r = split(/\s/, $self->{recode});
216 $log->logwarn("recode needs even number of elements (some number of valid pairs)");
221 $recode_map->{$from} = $to;
224 $recode_regex = join '|' => keys %{ $recode_map };
226 $log->debug("using recode regex: $recode_regex");
232 if (my $p = $arg->{modify_file}) {
233 $log->debug("using modify_file $p");
234 $rec_regex = $self->modify_file_regexps( $p );
235 } elsif (my $h = $arg->{modify_records}) {
236 $log->debug("using modify_records ", Dumper( $h ));
237 $rec_regex = $self->modify_record_regexps(%{ $h });
239 $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
241 my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
243 my $ll_db = $class->new(
244 path => $arg->{path},
246 # my ($l,$f_nr) = @_;
247 # return unless defined($l);
248 # from_to($l, $code_page, $self->{'encoding'});
249 # $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
255 unless (defined($ll_db)) {
256 $log->logwarn("can't open database $arg->{path}, skipping...");
260 my $size = $ll_db->size;
263 $log->logwarn("no records in database $arg->{path}, skipping...");
270 if (my $s = $self->{offset}) {
271 $log->debug("skipping to MFN $s");
274 $self->{offset} = $from_rec;
277 if ($self->{limit}) {
278 $log->debug("limiting to ",$self->{limit}," records");
279 $to_rec = $from_rec + $self->{limit} - 1;
280 $to_rec = $size if ($to_rec > $size);
283 # store size for later
284 $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
286 $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
289 for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
291 $log->debug("position: $pos\n");
293 my $rec = $ll_db->fetch_rec($pos, sub {
295 # return unless defined($l);
296 # return $l unless ($rec_regex && $f_nr);
298 $log->debug("-=> $f_nr ## $l");
300 # codepage conversion and recode_regex
301 from_to($l, $code_page, $self->{'encoding'});
302 $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
305 if ($rec_regex && defined($rec_regex->{$f_nr})) {
306 $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
308 foreach my $r (@{ $rec_regex->{$f_nr} }) {
312 $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
314 $log->error("error applying regex: $r") if ($@);
318 $log->debug("<=- $f_nr ## $l");
322 $log->debug(sub { Dumper($rec) });
325 $log->warn("record $pos empty? skipping...");
330 if ($self->{low_mem}) {
331 $self->{db}->put($pos, $rec);
333 $self->{data}->{$pos} = $rec;
337 $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
339 # update counters for statistics
340 if ($self->{stats}) {
342 # fetch clean record with regexpes applied for statistics
343 my $rec = $ll_db->fetch_rec($pos);
345 foreach my $fld (keys %{ $rec }) {
346 $self->{_stats}->{fld}->{ $fld }++;
348 $log->logdie("invalid record fild $fld, not ARRAY")
349 unless (ref($rec->{ $fld }) eq 'ARRAY');
351 foreach my $row (@{ $rec->{$fld} }) {
353 if (ref($row) eq 'HASH') {
355 foreach my $sf (keys %{ $row }) {
356 next if ($sf eq 'subfields');
357 $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
358 $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
359 if (ref($row->{$sf}) eq 'ARRAY');
363 $self->{_stats}->{repeatable}->{ $fld }++;
369 $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
374 $self->{last_pcnt} = 0;
376 # store max mfn and return it.
377 $self->{max_pos} = $to_rec;
378 $log->debug("max_pos: $to_rec");
381 $self->{ll_db} = $ll_db;
388 Fetch next record from database. It will also displays progress bar.
390 my $rec = $isis->fetch;
392 Record from this function should probably go to C<data_structure> for
400 my $log = $self->_get_logger();
402 $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
404 if ($self->{pos} == -1) {
405 $self->{pos} = $self->{offset};
410 my $mfn = $self->{pos};
412 if ($mfn > $self->{max_pos}) {
413 $self->{pos} = $self->{max_pos};
414 $log->debug("at EOF");
418 $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
422 if ($self->{low_mem}) {
423 $rec = $self->{db}->get($mfn);
425 $rec = $self->{data}->{$mfn};
433 Returns current record number (MFN).
437 First record in database has position 1.
449 Returns number of records in database
453 Result from this function can be used to loop through all records
455 foreach my $mfn ( 1 ... $isis->size ) { ... }
457 because it takes into account C<offset> and C<limit>.
463 return $self->{size};
468 Seek to specified MFN in file.
472 First record in database has position 1.
478 my $pos = shift || return;
480 my $log = $self->_get_logger();
483 $log->warn("seek before first record");
485 } elsif ($pos > $self->{max_pos}) {
486 $log->warn("seek beyond last record");
487 $pos = $self->{max_pos};
490 return $self->{pos} = (($pos - 1) || -1);
495 Dump statistics about field and subfield usage
504 my $log = $self->_get_logger();
506 my $s = $self->{_stats};
508 $log->warn("called stats, but there is no statistics collected");
516 my $f = $_ || die "no field";
517 my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
518 $max_fld = $v if ($v > $max_fld);
520 my $o = sprintf("%4s %d ~", $f, $v);
522 if (defined($s->{sf}->{$f})) {
524 $o .= sprintf(" %s:%d%s", $_,
525 $s->{sf}->{$f}->{$_}->{count},
526 $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
528 } sort keys %{ $s->{sf}->{$f} };
531 if (my $v_r = $s->{repeatable}->{$f}) {
532 $o .= " ($v_r)" if ($v_r != $v);
536 } sort { $a cmp $b } keys %{ $s->{fld} }
539 $log->debug( sub { Dumper($s) } );
546 Display humanly readable dump of record
553 return $self->{ll_db}->dump_rec( $self->{pos} );
557 =head2 modify_record_regexps
559 Generate hash with regexpes to be applied using l<filter>.
561 my $regexpes = $input->modify_record_regexps(
562 900 => { '^a' => { ' : ' => '^b' } },
563 901 => { '*' => { '^b' => ' ; ' } },
569 my ($sf,$from,$to) = @_;
572 's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
575 's/\Q'. $from .'\E/'. $to .'/g';
579 sub modify_record_regexps {
581 my $modify_record = {@_};
585 my $log = $self->_get_logger();
587 foreach my $f (keys %$modify_record) {
588 $log->debug("field: $f");
590 foreach my $sf (keys %{ $modify_record->{$f} }) {
591 $log->debug("subfield: $sf");
593 foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
594 my $to = $modify_record->{$f}->{$sf}->{$from};
595 #die "no field?" unless defined($to);
596 $log->debug("transform: |$from| -> |$to|");
598 my $regex = _get_regex($sf,$from,$to);
599 push @{ $regexpes->{$f} }, $regex;
600 $log->debug("regex: $regex");
608 =head2 modify_file_regexps
610 Generate hash with regexpes to be applied using l<filter> from
611 pseudo hash/yaml format for regex mappings.
613 It should be obvious:
620 In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
621 In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
623 my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
625 On undef path it will just return.
629 sub modify_file_regexps {
632 my $modify_path = shift || return;
634 my $log = $self->_get_logger();
638 CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
644 next if (/^#/ || /^\s*$/);
646 if (/^\s*(\d+)\s*$/) {
648 $log->debug("field: $f");
650 } elsif (/^\s*'([^']*)'\s*$/) {
652 $log->die("can't define subfiled before field in: $_") unless ($f);
653 $log->debug("subfield: $sf");
654 } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
655 my ($from,$to) = ($1, $2);
657 $log->debug("transform: |$from| -> |$to|");
659 my $regex = _get_regex($sf,$from,$to);
660 push @{ $regexpes->{$f} }, $regex;
661 $log->debug("regex: $regex");
670 C<low_mem> options is double-edged sword. If enabled, WebPAC
671 will run on memory constraint machines (which doesn't have enough
672 physical RAM to create memory structure for whole source database).
674 If your machine has 512Mb or more of RAM and database is around 10000 records,
675 memory shouldn't be an issue. If you don't have enough physical RAM, you
676 might consider using virtual memory (if your operating system is handling it
677 well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle
678 parsed structure of ISIS database (this is what C<low_mem> option does).
680 Hitting swap at end of reading source database is probably o.k. However,
681 hitting swap before 90% will dramatically decrease performance and you will
682 be better off with C<low_mem> and using rest of availble memory for
683 operating system disk cache (Linux is particuallary good about this).
684 However, every access to database record will require disk access, so
685 generation phase will be slower 10-100 times.
687 Parsed structures are essential - you just have option to trade RAM memory
688 (which is fast) for disk space (which is slow). Be sure to have planty of
689 disk space if you are using C<low_mem> and thus L<DBM::Deep>.
691 However, when WebPAC is running on desktop machines (or laptops :-), it's
692 highly undesireable for system to start swapping. Using C<low_mem> option can
693 reduce WecPAC memory usage to around 64Mb for same database with lookup
694 fields and sorted indexes which stay in RAM. Performance will suffer, but
695 memory usage will really be minimal. It might be also more confortable to
696 run WebPAC reniced on those machines.
701 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
703 =head1 COPYRIGHT & LICENSE
705 Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
707 This program is free software; you can redistribute it and/or modify it
708 under the same terms as Perl itself.
712 1; # End of WebPAC::Input