/[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 726 - (show annotations)
Fri Sep 29 19:52:17 2006 UTC (17 years, 6 months ago) by dpavlin
File size: 16744 byte(s)
 r1045@llin:  dpavlin | 2006-09-29 21:38:42 +0200
 change low-level API to be OO (and remove various ugly cludges).

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.13
20
21 =cut
22
23 our $VERSION = '0.13';
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_path = $self->{module};
102 $module_path =~ s#::#/#g;
103 $module_path .= '.pm';
104 $log->debug("require low-level module $self->{module} from $module_path");
105
106 require $module_path;
107
108 # check if required subclasses are implemented
109 foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
110 # FIXME
111 }
112
113 $self->{'encoding'} ||= 'ISO-8859-2';
114
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)");
118
119 my $db_file = "data.db";
120
121 if (-e $db_file) {
122 unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
123 $log->debug("removed '$db_file' from last run");
124 }
125
126 require DBM::Deep;
127
128 my $db = new DBM::Deep $db_file;
129
130 $log->logdie("DBM::Deep error: $!") unless ($db);
131
132 if ($db->error()) {
133 $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
134 } else {
135 $log->debug("using file '$db_file' for DBM::Deep");
136 }
137
138 $self->{'db'} = $db;
139 }
140
141 $self ? return $self : return undef;
142 }
143
144 =head2 open
145
146 This function will read whole database in memory and produce lookups.
147
148 $input->open(
149 path => '/path/to/database/file',
150 code_page => 'cp852',
151 limit => 500,
152 offset => 6000,
153 stats => 1,
154 lookup_coderef => sub {
155 my $rec = shift;
156 # store lookups
157 },
158 modify_records => {
159 900 => { '^a' => { ' : ' => '^b' } },
160 901 => { '*' => { '^b' => ' ; ' } },
161 },
162 modify_file => 'conf/modify/mapping.map',
163 );
164
165 By default, C<code_page> is assumed to be C<cp852>.
166
167 C<offset> is optional parametar to position at some offset before reading from database.
168
169 C<limit> is optional parametar to read just C<limit> records from database
170
171 C<stats> create optional report about usage of fields and subfields
172
173 C<lookup_coderef> is closure to called to save data into lookups
174
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
177 defined as C<*>.
178
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.
182
183 Returns size of database, regardless of C<offset> and C<limit>
184 parametars, see also C<size>.
185
186 =cut
187
188 sub open {
189 my $self = shift;
190 my $arg = {@_};
191
192 my $log = $self->_get_logger();
193
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');
197
198 $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
199
200 $log->logcroak("need path") if (! $arg->{'path'});
201 my $code_page = $arg->{'code_page'} || 'cp852';
202
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});
207 }
208
209 my $filter_ref;
210 my $recode_regex;
211 my $recode_map;
212
213 if ($self->{recode}) {
214 my @r = split(/\s/, $self->{recode});
215 if ($#r % 2 != 1) {
216 $log->logwarn("recode needs even number of elements (some number of valid pairs)");
217 } else {
218 while (@r) {
219 my $from = shift @r;
220 my $to = shift @r;
221 $recode_map->{$from} = $to;
222 }
223
224 $recode_regex = join '|' => keys %{ $recode_map };
225
226 $log->debug("using recode regex: $recode_regex");
227 }
228
229 }
230
231 my $rec_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 });
238 }
239 $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
240
241 my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
242
243 my $ll_db = $class->new(
244 path => $arg->{path},
245 # filter => sub {
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);
250 # return $l;
251 # },
252 %{ $arg },
253 );
254
255 unless (defined($ll_db)) {
256 $log->logwarn("can't open database $arg->{path}, skipping...");
257 return;
258 }
259
260 my $size = $ll_db->size;
261
262 unless ($size) {
263 $log->logwarn("no records in database $arg->{path}, skipping...");
264 return;
265 }
266
267 my $from_rec = 1;
268 my $to_rec = $size;
269
270 if (my $s = $self->{offset}) {
271 $log->debug("skipping to MFN $s");
272 $from_rec = $s;
273 } else {
274 $self->{offset} = $from_rec;
275 }
276
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);
281 }
282
283 # store size for later
284 $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
285
286 $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
287
288 # read database
289 for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
290
291 $log->debug("position: $pos\n");
292
293 my $rec = $ll_db->fetch_rec($pos, sub {
294 my ($l,$f_nr) = @_;
295 # return unless defined($l);
296 # return $l unless ($rec_regex && $f_nr);
297
298 $log->debug("-=> $f_nr ## $l");
299
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);
303
304 # apply regexps
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');
307 my $c = 0;
308 foreach my $r (@{ $rec_regex->{$f_nr} }) {
309 my $old_l = $l;
310 eval '$l =~ ' . $r;
311 if ($old_l ne $l) {
312 $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
313 }
314 $log->error("error applying regex: $r") if ($@);
315 }
316 }
317
318 $log->debug("<=- $f_nr ## $l");
319 return $l;
320 });
321
322 $log->debug(sub { Dumper($rec) });
323
324 if (! $rec) {
325 $log->warn("record $pos empty? skipping...");
326 next;
327 }
328
329 # store
330 if ($self->{low_mem}) {
331 $self->{db}->put($pos, $rec);
332 } else {
333 $self->{data}->{$pos} = $rec;
334 }
335
336 # create lookup
337 $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
338
339 # update counters for statistics
340 if ($self->{stats}) {
341
342 # fetch clean record with regexpes applied for statistics
343 my $rec = $ll_db->fetch_rec($pos);
344
345 foreach my $fld (keys %{ $rec }) {
346 $self->{_stats}->{fld}->{ $fld }++;
347
348 $log->logdie("invalid record fild $fld, not ARRAY")
349 unless (ref($rec->{ $fld }) eq 'ARRAY');
350
351 foreach my $row (@{ $rec->{$fld} }) {
352
353 if (ref($row) eq 'HASH') {
354
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');
360 }
361
362 } else {
363 $self->{_stats}->{repeatable}->{ $fld }++;
364 }
365 }
366 }
367 }
368
369 $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
370
371 }
372
373 $self->{pos} = -1;
374 $self->{last_pcnt} = 0;
375
376 # store max mfn and return it.
377 $self->{max_pos} = $to_rec;
378 $log->debug("max_pos: $to_rec");
379
380 return $size;
381 }
382
383 =head2 fetch
384
385 Fetch next record from database. It will also displays progress bar.
386
387 my $rec = $isis->fetch;
388
389 Record from this function should probably go to C<data_structure> for
390 normalisation.
391
392 =cut
393
394 sub fetch {
395 my $self = shift;
396
397 my $log = $self->_get_logger();
398
399 $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
400
401 if ($self->{pos} == -1) {
402 $self->{pos} = $self->{offset};
403 } else {
404 $self->{pos}++;
405 }
406
407 my $mfn = $self->{pos};
408
409 if ($mfn > $self->{max_pos}) {
410 $self->{pos} = $self->{max_pos};
411 $log->debug("at EOF");
412 return;
413 }
414
415 $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
416
417 my $rec;
418
419 if ($self->{low_mem}) {
420 $rec = $self->{db}->get($mfn);
421 } else {
422 $rec = $self->{data}->{$mfn};
423 }
424
425 $rec ||= 0E0;
426 }
427
428 =head2 pos
429
430 Returns current record number (MFN).
431
432 print $isis->pos;
433
434 First record in database has position 1.
435
436 =cut
437
438 sub pos {
439 my $self = shift;
440 return $self->{pos};
441 }
442
443
444 =head2 size
445
446 Returns number of records in database
447
448 print $isis->size;
449
450 Result from this function can be used to loop through all records
451
452 foreach my $mfn ( 1 ... $isis->size ) { ... }
453
454 because it takes into account C<offset> and C<limit>.
455
456 =cut
457
458 sub size {
459 my $self = shift;
460 return $self->{size};
461 }
462
463 =head2 seek
464
465 Seek to specified MFN in file.
466
467 $isis->seek(42);
468
469 First record in database has position 1.
470
471 =cut
472
473 sub seek {
474 my $self = shift;
475 my $pos = shift || return;
476
477 my $log = $self->_get_logger();
478
479 if ($pos < 1) {
480 $log->warn("seek before first record");
481 $pos = 1;
482 } elsif ($pos > $self->{max_pos}) {
483 $log->warn("seek beyond last record");
484 $pos = $self->{max_pos};
485 }
486
487 return $self->{pos} = (($pos - 1) || -1);
488 }
489
490 =head2 stats
491
492 Dump statistics about field and subfield usage
493
494 print $input->stats;
495
496 =cut
497
498 sub stats {
499 my $self = shift;
500
501 my $log = $self->_get_logger();
502
503 my $s = $self->{_stats};
504 if (! $s) {
505 $log->warn("called stats, but there is no statistics collected");
506 return;
507 }
508
509 my $max_fld = 0;
510
511 my $out = join("\n",
512 map {
513 my $f = $_ || die "no field";
514 my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
515 $max_fld = $v if ($v > $max_fld);
516
517 my $o = sprintf("%4s %d ~", $f, $v);
518
519 if (defined($s->{sf}->{$f})) {
520 map {
521 $o .= sprintf(" %s:%d%s", $_,
522 $s->{sf}->{$f}->{$_}->{count},
523 $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
524 );
525 } sort keys %{ $s->{sf}->{$f} };
526 }
527
528 if (my $v_r = $s->{repeatable}->{$f}) {
529 $o .= " ($v_r)" if ($v_r != $v);
530 }
531
532 $o;
533 } sort { $a cmp $b } keys %{ $s->{fld} }
534 );
535
536 $log->debug( sub { Dumper($s) } );
537
538 return $out;
539 }
540
541 =head2 dump
542
543 Display humanly readable dump of record
544
545 =cut
546
547 sub dump {
548 my $self = shift;
549
550 return $self->{dump_rec}->($self, $self->{pos});
551
552 }
553
554 =head2 modify_record_regexps
555
556 Generate hash with regexpes to be applied using l<filter>.
557
558 my $regexpes = $input->modify_record_regexps(
559 900 => { '^a' => { ' : ' => '^b' } },
560 901 => { '*' => { '^b' => ' ; ' } },
561 );
562
563 =cut
564
565 sub _get_regex {
566 my ($sf,$from,$to) = @_;
567 if ($sf =~ /^\^/) {
568 return
569 's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
570 } else {
571 return
572 's/\Q'. $from .'\E/'. $to .'/g';
573 }
574 }
575
576 sub modify_record_regexps {
577 my $self = shift;
578 my $modify_record = {@_};
579
580 my $regexpes;
581
582 my $log = $self->_get_logger();
583
584 foreach my $f (keys %$modify_record) {
585 $log->debug("field: $f");
586
587 foreach my $sf (keys %{ $modify_record->{$f} }) {
588 $log->debug("subfield: $sf");
589
590 foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
591 my $to = $modify_record->{$f}->{$sf}->{$from};
592 #die "no field?" unless defined($to);
593 $log->debug("transform: |$from| -> |$to|");
594
595 my $regex = _get_regex($sf,$from,$to);
596 push @{ $regexpes->{$f} }, $regex;
597 $log->debug("regex: $regex");
598 }
599 }
600 }
601
602 return $regexpes;
603 }
604
605 =head2 modify_file_regexps
606
607 Generate hash with regexpes to be applied using l<filter> from
608 pseudo hash/yaml format for regex mappings.
609
610 It should be obvious:
611
612 200
613 '^a'
614 ' : ' => '^e'
615 ' = ' => '^d'
616
617 In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
618 In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
619
620 my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
621
622 On undef path it will just return.
623
624 =cut
625
626 sub modify_file_regexps {
627 my $self = shift;
628
629 my $modify_path = shift || return;
630
631 my $log = $self->_get_logger();
632
633 my $regexpes;
634
635 CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
636
637 my ($f,$sf);
638
639 while(<$fh>) {
640 chomp;
641 next if (/^#/ || /^\s*$/);
642
643 if (/^\s*(\d+)\s*$/) {
644 $f = $1;
645 $log->debug("field: $f");
646 next;
647 } elsif (/^\s*'([^']*)'\s*$/) {
648 $sf = $1;
649 $log->die("can't define subfiled before field in: $_") unless ($f);
650 $log->debug("subfield: $sf");
651 } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
652 my ($from,$to) = ($1, $2);
653
654 $log->debug("transform: |$from| -> |$to|");
655
656 my $regex = _get_regex($sf,$from,$to);
657 push @{ $regexpes->{$f} }, $regex;
658 $log->debug("regex: $regex");
659 }
660 }
661
662 return $regexpes;
663 }
664
665 =head1 MEMORY USAGE
666
667 C<low_mem> options is double-edged sword. If enabled, WebPAC
668 will run on memory constraint machines (which doesn't have enough
669 physical RAM to create memory structure for whole source database).
670
671 If your machine has 512Mb or more of RAM and database is around 10000 records,
672 memory shouldn't be an issue. If you don't have enough physical RAM, you
673 might consider using virtual memory (if your operating system is handling it
674 well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle
675 parsed structure of ISIS database (this is what C<low_mem> option does).
676
677 Hitting swap at end of reading source database is probably o.k. However,
678 hitting swap before 90% will dramatically decrease performance and you will
679 be better off with C<low_mem> and using rest of availble memory for
680 operating system disk cache (Linux is particuallary good about this).
681 However, every access to database record will require disk access, so
682 generation phase will be slower 10-100 times.
683
684 Parsed structures are essential - you just have option to trade RAM memory
685 (which is fast) for disk space (which is slow). Be sure to have planty of
686 disk space if you are using C<low_mem> and thus L<DBM::Deep>.
687
688 However, when WebPAC is running on desktop machines (or laptops :-), it's
689 highly undesireable for system to start swapping. Using C<low_mem> option can
690 reduce WecPAC memory usage to around 64Mb for same database with lookup
691 fields and sorted indexes which stay in RAM. Performance will suffer, but
692 memory usage will really be minimal. It might be also more confortable to
693 run WebPAC reniced on those machines.
694
695
696 =head1 AUTHOR
697
698 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
699
700 =head1 COPYRIGHT & LICENSE
701
702 Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
703
704 This program is free software; you can redistribute it and/or modify it
705 under the same terms as Perl itself.
706
707 =cut
708
709 1; # End of WebPAC::Input

  ViewVC Help
Powered by ViewVC 1.1.26