/[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 844 - (show annotations)
Sat May 26 10:40:01 2007 UTC (16 years, 9 months ago) by dpavlin
File size: 16597 byte(s)
work with fields which have number 0 (as opposed to 000) which has been
noticed in the wild (invalid, but --stats shouldn't really die)

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

  ViewVC Help
Powered by ViewVC 1.1.26