/[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 1307 - (show annotations)
Mon Sep 21 16:42:25 2009 UTC (14 years, 5 months ago) by dpavlin
File size: 17600 byte(s)
cleanup WebPAC::Input
1 package WebPAC::Input;
2
3 use warnings;
4 use strict;
5
6 use lib 'lib';
7
8 use WebPAC::Common;
9 use base qw/WebPAC::Common/;
10 use Data::Dump qw/dump/;
11 use Encode qw/decode from_to/;
12 use YAML;
13
14 =head1 NAME
15
16 WebPAC::Input - read different file formats into WebPAC
17
18 =cut
19
20 our $VERSION = '0.19';
21
22 =head1 SYNOPSIS
23
24 This module implements input as database which have fixed and known
25 I<size> while indexing and single unique numeric identifier for database
26 position ranging from 1 to I<size>.
27
28 Simply, something that is indexed by unmber from 1 .. I<size>.
29
30 Examples of such databases are CDS/ISIS files, MARC files, lines in
31 text file, and so on.
32
33 Specific file formats are implemented using low-level interface modules,
34 located in C<WebPAC::Input::*> namespace which export C<open_db>,
35 C<fetch_rec> and optional C<init> functions.
36
37 Perhaps a little code snippet.
38
39 use WebPAC::Input;
40
41 my $db = WebPAC::Input->new(
42 module => 'WebPAC::Input::ISIS',
43 );
44
45 $db->open( path => '/path/to/database' );
46 print "database size: ",$db->size,"\n";
47 while (my $rec = $db->fetch) {
48 # do something with $rec
49 }
50
51
52
53 =head1 FUNCTIONS
54
55 =head2 new
56
57 Create new input database object.
58
59 my $db = new WebPAC::Input(
60 module => 'WebPAC::Input::MARC',
61 recode => 'char pairs',
62 no_progress_bar => 1,
63 input_config => {
64 mapping => [ 'foo', 'bar', 'baz' ],
65 },
66 );
67
68 C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
69 L<WebPAC::Input::MARC>.
70
71 C<recode> is optional string constisting of character or words pairs that
72 should be replaced in input stream.
73
74 C<no_progress_bar> disables progress bar output on C<STDOUT>
75
76 This function will also call low-level C<init> if it exists with same
77 parametars.
78
79 =cut
80
81 sub new {
82 my $class = shift;
83 my $self = {@_};
84 bless($self, $class);
85
86 my $log = $self->_get_logger;
87
88 $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
89 $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
90 $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if $self->{lookup};
91 $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if $self->{low_mem};
92
93 $log->logconfess("specify low-level file format module") unless ($self->{module});
94 my $module_path = $self->{module};
95 $module_path =~ s#::#/#g;
96 $module_path .= '.pm';
97 $log->debug("require low-level module $self->{module} from $module_path");
98
99 require $module_path;
100
101 $self ? return $self : return undef;
102 }
103
104 =head2 open
105
106 This function will read whole database in memory and produce lookups.
107
108 my $store; # simple in-memory hash
109
110 $input->open(
111 path => '/path/to/database/file',
112 input_encoding => 'cp852',
113 strict_encoding => 0,
114 limit => 500,
115 offset => 6000,
116 stats => 1,
117 lookup_coderef => sub {
118 my $rec = shift;
119 # store lookups
120 },
121 modify_records => {
122 900 => { '^a' => { ' : ' => '^b' } },
123 901 => { '*' => { '^b' => ' ; ' } },
124 },
125 modify_file => 'conf/modify/mapping.map',
126 save_row => sub {
127 my $a = shift;
128 $store->{ $a->{id} } = $a->{row};
129 },
130 load_row => sub {
131 my $a = shift;
132 return defined($store->{ $a->{id} }) &&
133 $store->{ $a->{id} };
134 },
135
136 );
137
138 By default, C<input_encoding> is assumed to be C<cp852>.
139
140 C<offset> is optional parametar to skip records at beginning.
141
142 C<limit> is optional parametar to read just C<limit> records from database
143
144 C<stats> create optional report about usage of fields and subfields
145
146 C<lookup_coderef> is closure to called to save data into lookups
147
148 C<modify_records> specify mapping from subfields to delimiters or from
149 delimiters to subfields, as well as oprations on fields (if subfield is
150 defined as C<*>.
151
152 C<modify_file> is alternative for C<modify_records> above which preserves order and offers
153 (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
154 overrides C<modify_records> if both exists for same input.
155
156 C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
157 is documented in example above.
158
159 C<strict_encoding> should really default to 1, but it doesn't for now.
160
161 Returns size of database, regardless of C<offset> and C<limit>
162 parametars, see also C<size>.
163
164 =cut
165
166 sub open {
167 my $self = shift;
168 my $arg = {@_};
169
170 my $log = $self->_get_logger();
171 $log->debug( "arguments: ",dump( $arg ));
172
173 $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
174 $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
175 $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
176 $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
177 if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
178
179 $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
180
181 $log->logcroak("need path") if (! $arg->{'path'});
182 my $input_encoding = $arg->{'input_encoding'} || $self->{'input_encoding'} || 'cp852';
183
184 # store data in object
185 $self->{$_} = $arg->{$_} foreach grep { defined $arg->{$_} } qw(path offset limit);
186
187 if ($arg->{load_row} || $arg->{save_row}) {
188 $log->logconfess("save_row and load_row must be defined in pair and be CODE") unless (
189 ref($arg->{load_row}) eq 'CODE' &&
190 ref($arg->{save_row}) eq 'CODE'
191 );
192 $self->{load_row} = $arg->{load_row};
193 $self->{save_row} = $arg->{save_row};
194 $log->debug("using load_row and save_row instead of in-memory hash");
195 }
196
197 my $filter_ref;
198 my $recode_regex;
199 my $recode_map;
200
201 if ($self->{recode}) {
202 my @r = split(/\s/, $self->{recode});
203 if ($#r % 2 != 1) {
204 $log->logwarn("recode needs even number of elements (some number of valid pairs)");
205 } else {
206 while (@r) {
207 my $from = shift @r;
208 my $to = shift @r;
209 $recode_map->{$from} = $to;
210 }
211
212 $recode_regex = join '|' => keys %{ $recode_map };
213
214 $log->debug("using recode regex: $recode_regex");
215 }
216
217 }
218
219 my $rec_regex;
220 if (my $p = $arg->{modify_file}) {
221 $log->debug("using modify_file $p");
222 $rec_regex = $self->modify_file_regexps( $p );
223 } elsif (my $h = $arg->{modify_records}) {
224 $log->debug("using modify_records ", sub { dump( $h ) });
225 $rec_regex = $self->modify_record_regexps(%{ $h });
226 }
227 $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
228
229 my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
230
231 $arg->{$_} = $self->{$_} foreach qw(offset limit);
232
233 my $ll_db = $class->new(
234 path => $arg->{path},
235 input_config => $arg->{input_config} || $self->{input_config},
236 # filter => sub {
237 # my ($l,$f_nr) = @_;
238 # return unless defined($l);
239 # $l = decode($input_encoding, $l);
240 # $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
241 # return $l;
242 # },
243 %{ $arg },
244 );
245
246 # save for dump and input_module
247 $self->{ll_db} = $ll_db;
248
249 unless (defined($ll_db)) {
250 $log->logwarn("can't open database $arg->{path}, skipping...");
251 return;
252 }
253
254 my $size = $ll_db->size;
255
256 unless ($size) {
257 $log->logwarn("no records in database $arg->{path}, skipping...");
258 return;
259 }
260
261 my $from_rec = 1;
262 my $to_rec = $size;
263
264 if (my $s = $self->{offset}) {
265 $log->debug("offset $s records");
266 $from_rec = $s + 1;
267 } else {
268 $self->{offset} = $from_rec - 1;
269 }
270
271 if ($self->{limit}) {
272 $log->debug("limiting to ",$self->{limit}," records");
273 $to_rec = $from_rec + $self->{limit} - 1;
274 $to_rec = $size if ($to_rec > $size);
275 }
276
277 my $strict_encoding = $arg->{strict_encoding} || $self->{strict_encoding}; ## FIXME should be 1 really
278
279 $log->info("processing $self->{size}/$size records [$from_rec-$to_rec]",
280 " encoding $input_encoding ", $strict_encoding ? ' [strict]' : '',
281 $self->{stats} ? ' [stats]' : '',
282 );
283
284 $self->{size} = 0;
285
286 # read database
287 for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
288
289 $log->debug("position: $pos\n");
290
291 $self->{size}++; # XXX I could move this more down if I didn't want empty records...
292
293 my $rec = $ll_db->fetch_rec($pos, sub {
294 my ($l,$f_nr,$debug) = @_;
295 # return unless defined($l);
296 # return $l unless ($rec_regex && $f_nr);
297
298 return unless ( defined($l) && defined($f_nr) );
299
300 warn "-=> $f_nr ## |$l|\n" if ($debug);
301 $log->debug("-=> $f_nr ## $l");
302
303 # codepage conversion and recode_regex
304 $l = decode($input_encoding, $l, 1);
305 $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
306
307 # apply regexps
308 if ($rec_regex && defined($rec_regex->{$f_nr})) {
309 $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
310 my $c = 0;
311 foreach my $r (@{ $rec_regex->{$f_nr} }) {
312 my $old_l = $l;
313 $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
314 eval '$l =~ ' . $r->{regex};
315 if ($old_l ne $l) {
316 my $d = "|$old_l| -> |$l| "; # . $r->{regex};
317 $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
318 $d .= ' ' . $r->{debug} if defined($r->{debug});
319 $log->debug("MODIFY $d");
320 warn "*** $d\n" if ($debug);
321
322 }
323 $log->error("error applying regex: ",dump($r), $@) if $@;
324 }
325 }
326
327 $log->debug("<=- $f_nr ## |$l|");
328 warn "<=- $f_nr ## $l\n" if ($debug);
329 return $l;
330 });
331
332 $log->debug(sub { dump($rec) });
333
334 if (! $rec) {
335 $log->warn("record $pos empty? skipping...");
336 next;
337 }
338
339 # store
340 if ($self->{save_row}) {
341 $self->{save_row}->({
342 id => $pos,
343 row => $rec,
344 });
345 } else {
346 $self->{data}->{$pos} = $rec;
347 }
348
349 # create lookup
350 $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
351
352 # update counters for statistics
353 if ($self->{stats}) {
354
355 # fetch clean record with regexpes applied for statistics
356 my $rec = $ll_db->fetch_rec($pos);
357
358 foreach my $fld (keys %{ $rec }) {
359 $self->{_stats}->{fld}->{ $fld }++;
360
361 #$log->logdie("invalid record fild $fld, not ARRAY")
362 next unless (ref($rec->{ $fld }) eq 'ARRAY');
363
364 foreach my $row (@{ $rec->{$fld} }) {
365
366 if (ref($row) eq 'HASH') {
367
368 foreach my $sf (keys %{ $row }) {
369 next if ($sf eq 'subfields');
370 $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
371 $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
372 if (ref($row->{$sf}) eq 'ARRAY');
373 }
374
375 } else {
376 $self->{_stats}->{repeatable}->{ $fld }++;
377 }
378 }
379 }
380 }
381
382 $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
383
384 }
385
386 $self->{pos} = -1;
387 $self->{last_pcnt} = 0;
388
389 # store max mfn and return it.
390 $self->{max_pos} = $to_rec;
391 $log->debug("max_pos: $to_rec");
392
393 return $size;
394 }
395
396 sub input_module { $_[0]->{ll_db} }
397
398 =head2 fetch
399
400 Fetch next record from database. It will also displays progress bar.
401
402 my $rec = $isis->fetch;
403
404 Record from this function should probably go to C<data_structure> for
405 normalisation.
406
407 =cut
408
409 sub fetch {
410 my $self = shift;
411
412 my $log = $self->_get_logger();
413
414 $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
415
416 if ($self->{pos} == -1) {
417 $self->{pos} = $self->{offset} + 1;
418 } else {
419 $self->{pos}++;
420 }
421
422 my $mfn = $self->{pos};
423
424 if ($mfn > $self->{max_pos}) {
425 $self->{pos} = $self->{max_pos};
426 $log->debug("at EOF");
427 return;
428 }
429
430 $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
431
432 my $rec;
433
434 if ($self->{load_row}) {
435 $rec = $self->{load_row}->({ id => $mfn });
436 } else {
437 $rec = $self->{data}->{$mfn};
438 }
439
440 $rec ||= 0E0;
441 }
442
443 =head2 pos
444
445 Returns current record number (MFN).
446
447 print $isis->pos;
448
449 First record in database has position 1.
450
451 =cut
452
453 sub pos {
454 my $self = shift;
455 return $self->{pos};
456 }
457
458
459 =head2 size
460
461 Returns number of records in database
462
463 print $isis->size;
464
465 Result from this function can be used to loop through all records
466
467 foreach my $mfn ( 1 ... $isis->size ) { ... }
468
469 because it takes into account C<offset> and C<limit>.
470
471 =cut
472
473 sub size {
474 my $self = shift;
475 return $self->{size}; # FIXME this is buggy if open is called multiple times!
476 }
477
478 =head2 seek
479
480 Seek to specified MFN in file.
481
482 $isis->seek(42);
483
484 First record in database has position 1.
485
486 =cut
487
488 sub seek {
489 my $self = shift;
490 my $pos = shift;
491
492 my $log = $self->_get_logger();
493
494 $log->logconfess("called without pos") unless defined($pos);
495
496 if ($pos < 1) {
497 $log->warn("seek before first record");
498 $pos = 1;
499 } elsif ($pos > $self->{max_pos}) {
500 $log->warn("seek beyond last record");
501 $pos = $self->{max_pos};
502 }
503
504 return $self->{pos} = (($pos - 1) || -1);
505 }
506
507 =head2 stats
508
509 Dump statistics about field and subfield usage
510
511 print $input->stats;
512
513 =cut
514
515 sub stats {
516 my $self = shift;
517
518 my $log = $self->_get_logger();
519
520 my $s = $self->{_stats};
521 if (! $s) {
522 $log->warn("called stats, but there is no statistics collected");
523 return;
524 }
525
526 my $max_fld = 0;
527
528 my $out = join("\n",
529 map {
530 my $f = $_;
531 die "no field in ", dump( $s->{fld} ) unless defined( $f );
532 my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
533 $max_fld = $v if ($v > $max_fld);
534
535 my $o = sprintf("%4s %d ~", $f, $v);
536
537 if (defined($s->{sf}->{$f})) {
538 my @subfields = keys %{ $s->{sf}->{$f} };
539 map {
540 $o .= sprintf(" %s:%d%s", $_,
541 $s->{sf}->{$f}->{$_}->{count},
542 $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
543 );
544 } (
545 # first indicators and other special subfields
546 sort( grep { length($_) > 1 } @subfields ),
547 # then subfileds (single char)
548 sort( grep { length($_) == 1 } @subfields ),
549 );
550 }
551
552 if (my $v_r = $s->{repeatable}->{$f}) {
553 $o .= " ($v_r)" if ($v_r != $v);
554 }
555
556 $o;
557 } sort {
558 if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
559 $a <=> $b
560 } else {
561 $a cmp $b
562 }
563 } keys %{ $s->{fld} }
564 );
565
566 $log->debug( sub { dump($s) } );
567
568 my $path = 'var/stats.yml';
569 YAML::DumpFile( $path, $s );
570 $log->info( 'created ', $path, ' with ', -s $path, ' bytes' );
571
572 return $out;
573 }
574
575 =head2 dump_ascii
576
577 Display humanly readable dump of record
578
579 =cut
580
581 sub dump_ascii {
582 my $self = shift;
583
584 return unless $self->{ll_db};
585
586 if ($self->{ll_db}->can('dump_ascii')) {
587 return $self->{ll_db}->dump_ascii( $self->{pos} );
588 } else {
589 return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
590 }
591 }
592
593 =head2 _get_regex
594
595 Helper function called which create regexps to be execute on code.
596
597 _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
598 _get_regex( 900, '^b', ' : ^b' );
599
600 It supports perl regexps with C<regex:> prefix to from value and has
601 additional logic to skip empty subfields.
602
603 =cut
604
605 sub _get_regex {
606 my ($sf,$from,$to) = @_;
607
608 # protect /
609 $from =~ s!/!\\/!gs;
610 $to =~ s!/!\\/!gs;
611
612 if ($from =~ m/^regex:(.+)$/) {
613 $from = $1;
614 } else {
615 $from = '\Q' . $from . '\E';
616 }
617 if ($sf =~ /^\^/) {
618 my $need_subfield_data = '*'; # no
619 # if from is also subfield, require some data in between
620 # to correctly skip empty subfields
621 $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
622 return
623 's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
624 } else {
625 return
626 's/'. $from .'/'. $to .'/g';
627 }
628 }
629
630
631 =head2 modify_record_regexps
632
633 Generate hash with regexpes to be applied using L<filter>.
634
635 my $regexpes = $input->modify_record_regexps(
636 900 => { '^a' => { ' : ' => '^b' } },
637 901 => { '*' => { '^b' => ' ; ' } },
638 );
639
640 =cut
641
642 sub modify_record_regexps {
643 my $self = shift;
644 my $modify_record = {@_};
645
646 my $regexpes;
647
648 my $log = $self->_get_logger();
649
650 foreach my $f (keys %$modify_record) {
651 $log->debug("field: $f");
652
653 foreach my $sf (keys %{ $modify_record->{$f} }) {
654 $log->debug("subfield: $sf");
655
656 foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
657 my $to = $modify_record->{$f}->{$sf}->{$from};
658 #die "no field?" unless defined($to);
659 my $d = "|$from| -> |$to|";
660 $log->debug("transform: $d");
661
662 my $regex = _get_regex($sf,$from,$to);
663 push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
664 $log->debug("regex: $regex");
665 }
666 }
667 }
668
669 return $regexpes;
670 }
671
672 =head2 modify_file_regexps
673
674 Generate hash with regexpes to be applied using L<filter> from
675 pseudo hash/yaml format for regex mappings.
676
677 It should be obvious:
678
679 200
680 '^a'
681 ' : ' => '^e'
682 ' = ' => '^d'
683
684 In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
685 In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
686
687 my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
688
689 On undef path it will just return.
690
691 =cut
692
693 sub modify_file_regexps {
694 my $self = shift;
695
696 my $modify_path = shift || return;
697
698 my $log = $self->_get_logger();
699
700 my $regexpes;
701
702 CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
703
704 my ($f,$sf);
705
706 while(<$fh>) {
707 chomp;
708 next if (/^#/ || /^\s*$/);
709
710 if (/^\s*(\d+)\s*$/) {
711 $f = $1;
712 $log->debug("field: $f");
713 next;
714 } elsif (/^\s*'([^']*)'\s*$/) {
715 $sf = $1;
716 $log->die("can't define subfiled before field in: $_") unless ($f);
717 $log->debug("subfield: $sf");
718 } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
719 my ($from,$to) = ($1, $2);
720
721 $log->debug("transform: |$from| -> |$to|");
722
723 my $regex = _get_regex($sf,$from,$to);
724 push @{ $regexpes->{$f} }, {
725 regex => $regex,
726 file => $modify_path,
727 line => $.,
728 };
729 $log->debug("regex: $regex");
730 } else {
731 die "can't parse: $_";
732 }
733 }
734
735 return $regexpes;
736 }
737
738 =head1 AUTHOR
739
740 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
741
742 =head1 COPYRIGHT & LICENSE
743
744 Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
745
746 This program is free software; you can redistribute it and/or modify it
747 under the same terms as Perl itself.
748
749 =cut
750
751 1; # End of WebPAC::Input

  ViewVC Help
Powered by ViewVC 1.1.26