9 use base qw/WebPAC::Common/;
15 WebPAC::Input - read different file formats into WebPAC
23 our $VERSION = '0.10';
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/) {
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',
165 lookup => $lookup_obj,
169 # store lookup $k => $v
172 900 => { '^a' => { ' : ' => '^b' } },
173 901 => { '*' => { '^b' => ' ; ' } },
177 By default, C<code_page> is assumed to be C<852>.
179 C<offset> is optional parametar to position at some offset before reading from database.
181 C<limit> is optional parametar to read just C<limit> records from database
183 C<stats> create optional report about usage of fields and subfields
185 C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to
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
192 Returns size of database, regardless of C<offset> and C<limit>
193 parametars, see also C<size>.
201 my $log = $self->_get_logger();
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');
207 $log->logcroak("need path") if (! $arg->{'path'});
208 my $code_page = $arg->{'code_page'} || '852';
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});
216 # create Text::Iconv object
217 $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'}); ## FIXME remove!
223 if ($self->{recode}) {
224 my @r = split(/\s/, $self->{recode});
226 $log->logwarn("recode needs even number of elements (some number of valid pairs)");
231 $recode_map->{$from} = $to;
234 $recode_regex = join '|' => keys %{ $recode_map };
236 $log->debug("using recode regex: $recode_regex");
241 my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });
242 $log->debug("rec_regex: ", Dumper($rec_regex));
244 my ($db, $size) = $self->{open_db}->( $self,
245 path => $arg->{path},
248 return unless defined($l);
250 ## FIXME remove iconv!
251 $l = $self->{iconv}->convert($l) if ($self->{iconv});
253 $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
255 ## FIXME remove this warning when we are sure that none of API is calling
257 #warn "filter called without field number" unless ($f_nr);
259 return $l unless ($rec_regex && $f_nr);
261 # my $max_regex = 100;
264 if ($rec_regex && defined($rec_regex->{$f_nr})) {
265 $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
267 foreach my $r (@{ $rec_regex->{$f_nr} }) {
268 #$log->debug("\$l = $l\neval \$l =~ $r");
270 $log->error("error applying regex: $r") if ($@);
272 # while ( $c < $max_regex && eval '$l =~ ' . $r ) { $c++ };
273 # $log->error("field $f_nr has more than $max_regex regex iterations\n\$l = $l\neval \$l =~ $r") if ($c == $max_regex);
283 unless (defined($db)) {
284 $log->logwarn("can't open database $arg->{path}, skipping...");
289 $log->logwarn("no records in database $arg->{path}, skipping...");
296 if (my $s = $self->{offset}) {
297 $log->debug("skipping to MFN $s");
300 $self->{offset} = $from_rec;
303 if ($self->{limit}) {
304 $log->debug("limiting to ",$self->{limit}," records");
305 $to_rec = $from_rec + $self->{limit} - 1;
306 $to_rec = $size if ($to_rec > $size);
309 # store size for later
310 $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
312 $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
315 for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
317 $log->debug("position: $pos\n");
319 my $rec = $self->{fetch_rec}->($self, $db, $pos );
321 $log->debug(sub { Dumper($rec) });
324 $log->warn("record $pos empty? skipping...");
329 if ($self->{low_mem}) {
330 $self->{db}->put($pos, $rec);
332 $self->{data}->{$pos} = $rec;
336 $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
338 # update counters for statistics
339 if ($self->{stats}) {
341 foreach my $fld (keys %{ $rec }) {
342 $self->{_stats}->{fld}->{ $fld }++;
344 $log->logdie("invalid record fild $fld, not ARRAY")
345 unless (ref($rec->{ $fld }) eq 'ARRAY');
347 foreach my $row (@{ $rec->{$fld} }) {
349 if (ref($row) eq 'HASH') {
351 foreach my $sf (keys %{ $row }) {
352 $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
353 $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
354 if (ref($row->{$sf}) eq 'ARRAY');
358 $self->{_stats}->{repeatable}->{ $fld }++;
364 $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
369 $self->{last_pcnt} = 0;
371 # store max mfn and return it.
372 $self->{max_pos} = $to_rec;
373 $log->debug("max_pos: $to_rec");
380 Fetch next record from database. It will also displays progress bar.
382 my $rec = $isis->fetch;
384 Record from this function should probably go to C<data_structure> for
392 my $log = $self->_get_logger();
394 $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
396 if ($self->{pos} == -1) {
397 $self->{pos} = $self->{offset};
402 my $mfn = $self->{pos};
404 if ($mfn > $self->{max_pos}) {
405 $self->{pos} = $self->{max_pos};
406 $log->debug("at EOF");
410 $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
414 if ($self->{low_mem}) {
415 $rec = $self->{db}->get($mfn);
417 $rec = $self->{data}->{$mfn};
425 Returns current record number (MFN).
429 First record in database has position 1.
441 Returns number of records in database
445 Result from this function can be used to loop through all records
447 foreach my $mfn ( 1 ... $isis->size ) { ... }
449 because it takes into account C<offset> and C<limit>.
455 return $self->{size};
460 Seek to specified MFN in file.
464 First record in database has position 1.
470 my $pos = shift || return;
472 my $log = $self->_get_logger();
475 $log->warn("seek before first record");
477 } elsif ($pos > $self->{max_pos}) {
478 $log->warn("seek beyond last record");
479 $pos = $self->{max_pos};
482 return $self->{pos} = (($pos - 1) || -1);
487 Dump statistics about field and subfield usage
496 my $log = $self->_get_logger();
498 my $s = $self->{_stats};
500 $log->warn("called stats, but there is no statistics collected");
508 my $f = $_ || die "no field";
509 my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
510 $max_fld = $v if ($v > $max_fld);
512 my $o = sprintf("%4s %d ~", $f, $v);
514 if (defined($s->{sf}->{$f})) {
516 $o .= sprintf(" %s:%d%s", $_,
517 $s->{sf}->{$f}->{$_}->{count},
518 $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
520 } sort keys %{ $s->{sf}->{$f} };
523 if (my $v_r = $s->{repeatable}->{$f}) {
524 $o .= " ($v_r)" if ($v_r != $v);
528 } sort { $a cmp $b } keys %{ $s->{fld} }
531 $log->debug( sub { Dumper($s) } );
536 =head2 modify_record_regexps
538 Generate hash with regexpes to be applied using L<filter>.
540 my $regexpes = $input->modify_record_regexps(
541 900 => { '^a' => { ' : ' => '^b' } },
542 901 => { '*' => { '^b' => ' ; ' } },
547 sub modify_record_regexps {
549 my $modify_record = {@_};
553 foreach my $f (keys %$modify_record) {
555 foreach my $sf (keys %{ $modify_record->{$f} }) {
556 warn "---- sf: $sf\n";
557 foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
558 my $to = $modify_record->{$f}->{$sf}->{$from};
559 #die "no field?" unless defined($to);
560 warn "----- transform: |$from| -> |$to|\n";
564 's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
565 push @{ $regexpes->{$f} }, $regex;
566 warn ">>>>> $regex [sf]\n";
569 's/\Q'. $from .'\E/'. $to .'/g';
570 push @{ $regexpes->{$f} }, $regex;
571 warn ">>>>> $regex [global]\n";
583 C<low_mem> options is double-edged sword. If enabled, WebPAC
584 will run on memory constraint machines (which doesn't have enough
585 physical RAM to create memory structure for whole source database).
587 If your machine has 512Mb or more of RAM and database is around 10000 records,
588 memory shouldn't be an issue. If you don't have enough physical RAM, you
589 might consider using virtual memory (if your operating system is handling it
590 well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle
591 parsed structure of ISIS database (this is what C<low_mem> option does).
593 Hitting swap at end of reading source database is probably o.k. However,
594 hitting swap before 90% will dramatically decrease performance and you will
595 be better off with C<low_mem> and using rest of availble memory for
596 operating system disk cache (Linux is particuallary good about this).
597 However, every access to database record will require disk access, so
598 generation phase will be slower 10-100 times.
600 Parsed structures are essential - you just have option to trade RAM memory
601 (which is fast) for disk space (which is slow). Be sure to have planty of
602 disk space if you are using C<low_mem> and thus L<DBM::Deep>.
604 However, when WebPAC is running on desktop machines (or laptops :-), it's
605 highly undesireable for system to start swapping. Using C<low_mem> option can
606 reduce WecPAC memory usage to around 64Mb for same database with lookup
607 fields and sorted indexes which stay in RAM. Performance will suffer, but
608 memory usage will really be minimal. It might be also more confortable to
609 run WebPAC reniced on those machines.
614 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
616 =head1 COPYRIGHT & LICENSE
618 Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
620 This program is free software; you can redistribute it and/or modify it
621 under the same terms as Perl itself.
625 1; # End of WebPAC::Input