/[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

Contents of /trunk/lib/WebPAC/Input.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 625 - (show annotations)
Sat Aug 26 12:00:36 2006 UTC (17 years, 8 months ago) by dpavlin
File size: 14927 byte(s)
 r878@llin:  dpavlin | 2006-08-26 14:00:08 +0200
 removed some debugging output (or moved it to debug level), few tweaks [2.26]

1 package WebPAC::Input;
2
3 use warnings;
4 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
14
15 WebPAC::Input - read different file formats into WebPAC
16
17 =head1 VERSION
18
19 Version 0.11
20
21 =cut
22
23 our $VERSION = '0.11';
24
25 =head1 SYNOPSIS
26
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>.
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.
41
42 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
55
56
57 =head1 FUNCTIONS
58
59 =head2 new
60
61 Create new input database object.
62
63 my $db = new WebPAC::Input(
64 module => 'WebPAC::Input::MARC',
65 encoding => 'ISO-8859-2',
66 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
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
76 default, it C<ISO-8859-2>.
77
78 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
89
90 sub new {
91 my $class = shift;
92 my $self = {@_};
93 bless($self, $class);
94
95 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.
128 if ($self->{'low_mem'}) {
129 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
130
131 my $db_file = "data.db";
132
133 if (-e $db_file) {
134 unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
135 $log->debug("removed '$db_file' from last run");
136 }
137
138 require DBM::Deep;
139
140 my $db = new DBM::Deep $db_file;
141
142 $log->logdie("DBM::Deep error: $!") unless ($db);
143
144 if ($db->error()) {
145 $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
146 } else {
147 $log->debug("using file '$db_file' for DBM::Deep");
148 }
149
150 $self->{'db'} = $db;
151 }
152
153 $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 $log->debug("-=> $f_nr ## $l");
295
296 # codepage conversion and recode_regex
297 # from_to($l, $code_page, $self->{'encoding'});
298 from_to($l, $code_page, 'utf-8');
299 $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
300
301 # apply regexps
302 if ($rec_regex && defined($rec_regex->{$f_nr})) {
303 $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
304 my $c = 0;
305 foreach my $r (@{ $rec_regex->{$f_nr} }) {
306 #$log->debug("\$l = $l\neval \$l =~ $r");
307 eval '$l =~ ' . $r;
308 $log->error("error applying regex: $r") if ($@);
309 }
310 }
311
312 $log->debug("<=- $f_nr ## $l");
313 return $l;
314 });
315
316 $log->debug(sub { Dumper($rec) });
317
318 if (! $rec) {
319 $log->warn("record $pos empty? skipping...");
320 next;
321 }
322
323 # store
324 if ($self->{low_mem}) {
325 $self->{db}->put($pos, $rec);
326 } else {
327 $self->{data}->{$pos} = $rec;
328 }
329
330 # create lookup
331 $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
332
333 # update counters for statistics
334 if ($self->{stats}) {
335
336 # fetch clean record with regexpes applied for statistics
337 my $rec = $self->{fetch_rec}->($self, $db, $pos);
338
339 foreach my $fld (keys %{ $rec }) {
340 $self->{_stats}->{fld}->{ $fld }++;
341
342 $log->logdie("invalid record fild $fld, not ARRAY")
343 unless (ref($rec->{ $fld }) eq 'ARRAY');
344
345 foreach my $row (@{ $rec->{$fld} }) {
346
347 if (ref($row) eq 'HASH') {
348
349 foreach my $sf (keys %{ $row }) {
350 next if ($sf eq 'subfields');
351 $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
352 $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
353 if (ref($row->{$sf}) eq 'ARRAY');
354 }
355
356 } else {
357 $self->{_stats}->{repeatable}->{ $fld }++;
358 }
359 }
360 }
361 }
362
363 $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
364
365 }
366
367 $self->{pos} = -1;
368 $self->{last_pcnt} = 0;
369
370 # store max mfn and return it.
371 $self->{max_pos} = $to_rec;
372 $log->debug("max_pos: $to_rec");
373
374 return $size;
375 }
376
377 =head2 fetch
378
379 Fetch next record from database. It will also displays progress bar.
380
381 my $rec = $isis->fetch;
382
383 Record from this function should probably go to C<data_structure> for
384 normalisation.
385
386 =cut
387
388 sub fetch {
389 my $self = shift;
390
391 my $log = $self->_get_logger();
392
393 $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
394
395 if ($self->{pos} == -1) {
396 $self->{pos} = $self->{offset};
397 } else {
398 $self->{pos}++;
399 }
400
401 my $mfn = $self->{pos};
402
403 if ($mfn > $self->{max_pos}) {
404 $self->{pos} = $self->{max_pos};
405 $log->debug("at EOF");
406 return;
407 }
408
409 $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
410
411 my $rec;
412
413 if ($self->{low_mem}) {
414 $rec = $self->{db}->get($mfn);
415 } else {
416 $rec = $self->{data}->{$mfn};
417 }
418
419 $rec ||= 0E0;
420 }
421
422 =head2 pos
423
424 Returns current record number (MFN).
425
426 print $isis->pos;
427
428 First record in database has position 1.
429
430 =cut
431
432 sub pos {
433 my $self = shift;
434 return $self->{pos};
435 }
436
437
438 =head2 size
439
440 Returns number of records in database
441
442 print $isis->size;
443
444 Result from this function can be used to loop through all records
445
446 foreach my $mfn ( 1 ... $isis->size ) { ... }
447
448 because it takes into account C<offset> and C<limit>.
449
450 =cut
451
452 sub size {
453 my $self = shift;
454 return $self->{size};
455 }
456
457 =head2 seek
458
459 Seek to specified MFN in file.
460
461 $isis->seek(42);
462
463 First record in database has position 1.
464
465 =cut
466
467 sub seek {
468 my $self = shift;
469 my $pos = shift || return;
470
471 my $log = $self->_get_logger();
472
473 if ($pos < 1) {
474 $log->warn("seek before first record");
475 $pos = 1;
476 } elsif ($pos > $self->{max_pos}) {
477 $log->warn("seek beyond last record");
478 $pos = $self->{max_pos};
479 }
480
481 return $self->{pos} = (($pos - 1) || -1);
482 }
483
484 =head2 stats
485
486 Dump statistics about field and subfield usage
487
488 print $input->stats;
489
490 =cut
491
492 sub stats {
493 my $self = shift;
494
495 my $log = $self->_get_logger();
496
497 my $s = $self->{_stats};
498 if (! $s) {
499 $log->warn("called stats, but there is no statistics collected");
500 return;
501 }
502
503 my $max_fld = 0;
504
505 my $out = join("\n",
506 map {
507 my $f = $_ || die "no field";
508 my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
509 $max_fld = $v if ($v > $max_fld);
510
511 my $o = sprintf("%4s %d ~", $f, $v);
512
513 if (defined($s->{sf}->{$f})) {
514 map {
515 $o .= sprintf(" %s:%d%s", $_,
516 $s->{sf}->{$f}->{$_}->{count},
517 $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
518 );
519 } sort keys %{ $s->{sf}->{$f} };
520 }
521
522 if (my $v_r = $s->{repeatable}->{$f}) {
523 $o .= " ($v_r)" if ($v_r != $v);
524 }
525
526 $o;
527 } sort { $a cmp $b } keys %{ $s->{fld} }
528 );
529
530 $log->debug( sub { Dumper($s) } );
531
532 return $out;
533 }
534
535 =head2 modify_record_regexps
536
537 Generate hash with regexpes to be applied using L<filter>.
538
539 my $regexpes = $input->modify_record_regexps(
540 900 => { '^a' => { ' : ' => '^b' } },
541 901 => { '*' => { '^b' => ' ; ' } },
542 );
543
544 =cut
545
546 sub modify_record_regexps {
547 my $self = shift;
548 my $modify_record = {@_};
549
550 my $regexpes;
551
552 foreach my $f (keys %$modify_record) {
553 warn "--- f: $f\n";
554 foreach my $sf (keys %{ $modify_record->{$f} }) {
555 warn "---- sf: $sf\n";
556 foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
557 my $to = $modify_record->{$f}->{$sf}->{$from};
558 #die "no field?" unless defined($to);
559 warn "----- transform: |$from| -> |$to|\n";
560
561 if ($sf =~ /^\^/) {
562 my $regex =
563 's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';
564 push @{ $regexpes->{$f} }, $regex;
565 warn ">>>>> $regex [sf]\n";
566 } else {
567 my $regex =
568 's/\Q'. $from .'\E/'. $to .'/g';
569 push @{ $regexpes->{$f} }, $regex;
570 warn ">>>>> $regex [global]\n";
571 }
572
573 }
574 }
575 }
576
577 return $regexpes;
578 }
579
580 =head1 MEMORY USAGE
581
582 C<low_mem> options is double-edged sword. If enabled, WebPAC
583 will run on memory constraint machines (which doesn't have enough
584 physical RAM to create memory structure for whole source database).
585
586 If your machine has 512Mb or more of RAM and database is around 10000 records,
587 memory shouldn't be an issue. If you don't have enough physical RAM, you
588 might consider using virtual memory (if your operating system is handling it
589 well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle
590 parsed structure of ISIS database (this is what C<low_mem> option does).
591
592 Hitting swap at end of reading source database is probably o.k. However,
593 hitting swap before 90% will dramatically decrease performance and you will
594 be better off with C<low_mem> and using rest of availble memory for
595 operating system disk cache (Linux is particuallary good about this).
596 However, every access to database record will require disk access, so
597 generation phase will be slower 10-100 times.
598
599 Parsed structures are essential - you just have option to trade RAM memory
600 (which is fast) for disk space (which is slow). Be sure to have planty of
601 disk space if you are using C<low_mem> and thus L<DBM::Deep>.
602
603 However, when WebPAC is running on desktop machines (or laptops :-), it's
604 highly undesireable for system to start swapping. Using C<low_mem> option can
605 reduce WecPAC memory usage to around 64Mb for same database with lookup
606 fields and sorted indexes which stay in RAM. Performance will suffer, but
607 memory usage will really be minimal. It might be also more confortable to
608 run WebPAC reniced on those machines.
609
610
611 =head1 AUTHOR
612
613 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
614
615 =head1 COPYRIGHT & LICENSE
616
617 Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
618
619 This program is free software; you can redistribute it and/or modify it
620 under the same terms as Perl itself.
621
622 =cut
623
624 1; # End of WebPAC::Input

  ViewVC Help
Powered by ViewVC 1.1.26