git.rot13.org Git - webpac2/blob - lib/WebPAC/Input.pm

   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