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.12';
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 = $self->{module};
104 $log->debug("require low-level module $self->{module} from $module");
107 #eval $self->{module} .'->import';
109 # check if required subclasses are implemented
110 foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
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) };
116 $self->{$subclass} = \&{ $n };
121 $log->debug("calling init");
122 $self->{init}->($self, @_);
125 $self->{'encoding'} ||= 'ISO-8859-2';
127 # running with low_mem flag? well, use DBM::Deep then.
128 if ($self->{'low_mem'}) {
129 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
131 my $db_file = "data.db";
134 unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
135 $log->debug("removed '$db_file' from last run");
140 my $db = new DBM::Deep $db_file;
142 $log->logdie("DBM::Deep error: $!") unless ($db);
145 $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
147 $log->debug("using file '$db_file' for DBM::Deep");
153 $self ? return $self : return undef;
158 This function will read whole database in memory and produce lookups.
161 path => '/path/to/database/file',
162 code_page => 'cp852',
165 lookup => $lookup_obj,
169 # store lookup $k => $v
172 900 => { '^a' => { ' : ' => '^b' } },
173 901 => { '*' => { '^b' => ' ; ' } },
175 modify_file => 'conf/modify/mapping.map',
178 By default, C<code_page> is assumed to be C<cp852>.
180 C<offset> is optional parametar to position at some offset before reading from database.
182 C<limit> is optional parametar to read just C<limit> records from database
184 C<stats> create optional report about usage of fields and subfields
186 C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to
189 C<modify_records> specify mapping from subfields to delimiters or from
190 delimiters to subfields, as well as oprations on fields (if subfield is
193 C<modify_file> is alternative for C<modify_records> above which preserves order and offers
194 (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
195 overrides C<modify_records> if both exists for same input.
197 Returns size of database, regardless of C<offset> and C<limit>
198 parametars, see also C<size>.
206 my $log = $self->_get_logger();
208 $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
209 $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
210 if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
212 $log->logcroak("need path") if (! $arg->{'path'});
213 my $code_page = $arg->{'code_page'} || 'cp852';
215 # store data in object
216 $self->{'input_code_page'} = $code_page;
217 foreach my $v (qw/path offset limit/) {
218 $self->{$v} = $arg->{$v} if ($arg->{$v});
225 if ($self->{recode}) {
226 my @r = split(/\s/, $self->{recode});
228 $log->logwarn("recode needs even number of elements (some number of valid pairs)");
233 $recode_map->{$from} = $to;
236 $recode_regex = join '|' => keys %{ $recode_map };
238 $log->debug("using recode regex: $recode_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 });
251 $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
253 my ($db, $size) = $self->{open_db}->( $self,
254 path => $arg->{path},
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);
265 unless (defined($db)) {
266 $log->logwarn("can't open database $arg->{path}, skipping...");
271 $log->logwarn("no records in database $arg->{path}, skipping...");
278 if (my $s = $self->{offset}) {
279 $log->debug("skipping to MFN $s");
282 $self->{offset} = $from_rec;
285 if ($self->{limit}) {
286 $log->debug("limiting to ",$self->{limit}," records");
287 $to_rec = $from_rec + $self->{limit} - 1;
288 $to_rec = $size if ($to_rec > $size);
291 # store size for later
292 $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
294 $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
297 for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
299 $log->debug("position: $pos\n");
301 my $rec = $self->{fetch_rec}->($self, $pos, sub {
303 # return unless defined($l);
304 # return $l unless ($rec_regex && $f_nr);
306 $log->debug("-=> $f_nr ## $l");
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);
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');
316 foreach my $r (@{ $rec_regex->{$f_nr} }) {
320 $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
322 $log->error("error applying regex: $r") if ($@);
326 $log->debug("<=- $f_nr ## $l");
330 $log->debug(sub { Dumper($rec) });
333 $log->warn("record $pos empty? skipping...");
338 if ($self->{low_mem}) {
339 $self->{db}->put($pos, $rec);
341 $self->{data}->{$pos} = $rec;
345 $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
347 # update counters for statistics
348 if ($self->{stats}) {
350 # fetch clean record with regexpes applied for statistics
351 my $rec = $self->{fetch_rec}->($self, $pos);
353 foreach my $fld (keys %{ $rec }) {
354 $self->{_stats}->{fld}->{ $fld }++;
356 $log->logdie("invalid record fild $fld, not ARRAY")
357 unless (ref($rec->{ $fld }) eq 'ARRAY');
359 foreach my $row (@{ $rec->{$fld} }) {
361 if (ref($row) eq 'HASH') {
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');
371 $self->{_stats}->{repeatable}->{ $fld }++;
377 $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
382 $self->{last_pcnt} = 0;
384 # store max mfn and return it.
385 $self->{max_pos} = $to_rec;
386 $log->debug("max_pos: $to_rec");
393 Fetch next record from database. It will also displays progress bar.
395 my $rec = $isis->fetch;
397 Record from this function should probably go to C<data_structure> for
405 my $log = $self->_get_logger();
407 $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
409 if ($self->{pos} == -1) {
410 $self->{pos} = $self->{offset};
415 my $mfn = $self->{pos};
417 if ($mfn > $self->{max_pos}) {
418 $self->{pos} = $self->{max_pos};
419 $log->debug("at EOF");
423 $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
427 if ($self->{low_mem}) {
428 $rec = $self->{db}->get($mfn);
430 $rec = $self->{data}->{$mfn};
438 Returns current record number (MFN).
442 First record in database has position 1.
454 Returns number of records in database
458 Result from this function can be used to loop through all records
460 foreach my $mfn ( 1 ... $isis->size ) { ... }
462 because it takes into account C<offset> and C<limit>.
468 return $self->{size};
473 Seek to specified MFN in file.
477 First record in database has position 1.
483 my $pos = shift || return;
485 my $log = $self->_get_logger();
488 $log->warn("seek before first record");
490 } elsif ($pos > $self->{max_pos}) {
491 $log->warn("seek beyond last record");
492 $pos = $self->{max_pos};
495 return $self->{pos} = (($pos - 1) || -1);
500 Dump statistics about field and subfield usage
509 my $log = $self->_get_logger();
511 my $s = $self->{_stats};
513 $log->warn("called stats, but there is no statistics collected");
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);
525 my $o = sprintf("%4s %d ~", $f, $v);
527 if (defined($s->{sf}->{$f})) {
529 $o .= sprintf(" %s:%d%s", $_,
530 $s->{sf}->{$f}->{$_}->{count},
531 $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
533 } sort keys %{ $s->{sf}->{$f} };
536 if (my $v_r = $s->{repeatable}->{$f}) {
537 $o .= " ($v_r)" if ($v_r != $v);
541 } sort { $a cmp $b } keys %{ $s->{fld} }
544 $log->debug( sub { Dumper($s) } );
551 Display humanly readable dump of record
558 return $self->{dump_rec}->($self, $self->{pos});
562 =head2 modify_record_regexps
564 Generate hash with regexpes to be applied using l<filter>.
566 my $regexpes = $input->modify_record_regexps(
567 900 => { '^a' => { ' : ' => '^b' } },
568 901 => { '*' => { '^b' => ' ; ' } },
574 my ($sf,$from,$to) = @_;
577 's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
580 's/\Q'. $from .'\E/'. $to .'/g';
584 sub modify_record_regexps {
586 my $modify_record = {@_};
590 my $log = $self->_get_logger();
592 foreach my $f (keys %$modify_record) {
593 $log->debug("field: $f");
595 foreach my $sf (keys %{ $modify_record->{$f} }) {
596 $log->debug("subfield: $sf");
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|");
603 my $regex = _get_regex($sf,$from,$to);
604 push @{ $regexpes->{$f} }, $regex;
605 $log->debug("regex: $regex");
613 =head2 modify_file_regexps
615 Generate hash with regexpes to be applied using l<filter> from
616 pseudo hash/yaml format for regex mappings.
618 It should be obvious:
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'>.
628 my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
630 On undef path it will just return.
634 sub modify_file_regexps {
637 my $modify_path = shift || return;
639 my $log = $self->_get_logger();
643 CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
649 next if (/^#/ || /^\s*$/);
651 if (/^\s*(\d+)\s*$/) {
653 $log->debug("field: $f");
655 } elsif (/^\s*'([^']*)'\s*$/) {
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);
662 $log->debug("transform: |$from| -> |$to|");
664 my $regex = _get_regex($sf,$from,$to);
665 push @{ $regexpes->{$f} }, $regex;
666 $log->debug("regex: $regex");
675 C<low_mem> options is double-edged sword. If enabled, WebPAC
676 will run on memory constraint machines (which doesn't have enough
677 physical RAM to create memory structure for whole source database).
679 If your machine has 512Mb or more of RAM and database is around 10000 records,
680 memory shouldn't be an issue. If you don't have enough physical RAM, you
681 might consider using virtual memory (if your operating system is handling it
682 well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle
683 parsed structure of ISIS database (this is what C<low_mem> option does).
685 Hitting swap at end of reading source database is probably o.k. However,
686 hitting swap before 90% will dramatically decrease performance and you will
687 be better off with C<low_mem> and using rest of availble memory for
688 operating system disk cache (Linux is particuallary good about this).
689 However, every access to database record will require disk access, so
690 generation phase will be slower 10-100 times.
692 Parsed structures are essential - you just have option to trade RAM memory
693 (which is fast) for disk space (which is slow). Be sure to have planty of
694 disk space if you are using C<low_mem> and thus L<DBM::Deep>.
696 However, when WebPAC is running on desktop machines (or laptops :-), it's
697 highly undesireable for system to start swapping. Using C<low_mem> option can
698 reduce WecPAC memory usage to around 64Mb for same database with lookup
699 fields and sorted indexes which stay in RAM. Performance will suffer, but
700 memory usage will really be minimal. It might be also more confortable to
701 run WebPAC reniced on those machines.
706 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
708 =head1 COPYRIGHT & LICENSE
710 Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
712 This program is free software; you can redistribute it and/or modify it
713 under the same terms as Perl itself.
717 1; # End of WebPAC::Input