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

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 707 by dpavlin, Mon Sep 25 15:26:12 2006 UTC revision 1307 by dpavlin, Mon Sep 21 16:42:25 2009 UTC
# Line 3  package WebPAC::Input; Line 3  package WebPAC::Input;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6  use blib;  use lib 'lib';
7    
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Data::Dumper;  use Data::Dump qw/dump/;
11  use Encode qw/from_to/;  use Encode qw/decode from_to/;
12    use YAML;
13    
14  =head1 NAME  =head1 NAME
15    
16  WebPAC::Input - read different file formats into WebPAC  WebPAC::Input - read different file formats into WebPAC
17    
 =head1 VERSION  
   
 Version 0.13  
   
18  =cut  =cut
19    
20  our $VERSION = '0.13';  our $VERSION = '0.19';
21    
22  =head1 SYNOPSIS  =head1 SYNOPSIS
23    
# Line 43  Perhaps a little code snippet. Line 40  Perhaps a little code snippet.
40    
41          my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
42                  module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
                 low_mem => 1,  
43          );          );
44    
45          $db->open( path => '/path/to/database' );          $db->open( path => '/path/to/database' );
# Line 62  Create new input database object. Line 58  Create new input database object.
58    
59    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
60          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
         encoding => 'ISO-8859-2',  
         low_mem => 1,  
61          recode => 'char pairs',          recode => 'char pairs',
62          no_progress_bar => 1,          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  C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
69  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
70    
 Optional parametar C<encoding> specify application code page (which will be  
 used internally). This should probably be your terminal encoding, and by  
 default, it C<ISO-8859-2>.  
   
 Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  
   
71  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
72  should be replaced in input stream.  should be replaced in input stream.
73    
# Line 94  sub new { Line 85  sub new {
85    
86          my $log = $self->_get_logger;          my $log = $self->_get_logger;
87    
88          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});          $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
89          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});          $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});          $log->logconfess("specify low-level file format module") unless ($self->{module});
94          my $module = $self->{module};          my $module_path = $self->{module};
95          $module =~ s#::#/#g;          $module_path =~ s#::#/#g;
96          $module .= '.pm';          $module_path .= '.pm';
97          $log->debug("require low-level module $self->{module} from $module");          $log->debug("require low-level module $self->{module} from $module_path");
   
         require $module;  
         #eval $self->{module} .'->import';  
   
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {  
                 my $n = $self->{module} . '::' . $subclass;  
                 if (! defined &{ $n }) {  
                         my $missing = "missing $subclass in $self->{module}";  
                         $self->{$subclass} = sub { $log->logwarn($missing) };  
                 } else {  
                         $self->{$subclass} = \&{ $n };  
                 }  
         }  
   
         if ($self->{init}) {  
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
         }  
   
         $self->{'encoding'} ||= 'ISO-8859-2';  
   
         # running with low_mem flag? well, use DBM::Deep then.  
         if ($self->{'low_mem'}) {  
                 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");  
98    
99                  my $db_file = "data.db";          require $module_path;
   
                 if (-e $db_file) {  
                         unlink $db_file or $log->logdie("can't remove '$db_file' from last run");  
                         $log->debug("removed '$db_file' from last run");  
                 }  
   
                 require DBM::Deep;  
   
                 my $db = new DBM::Deep $db_file;  
   
                 $log->logdie("DBM::Deep error: $!") unless ($db);  
   
                 if ($db->error()) {  
                         $log->logdie("can't open '$db_file' under low_mem: ",$db->error());  
                 } else {  
                         $log->debug("using file '$db_file' for DBM::Deep");  
                 }  
   
                 $self->{'db'} = $db;  
         }  
100    
101          $self ? return $self : return undef;          $self ? return $self : return undef;
102  }  }
# Line 157  sub new { Line 105  sub new {
105    
106  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
107    
108     my $store;     # simple in-memory hash
109    
110   $input->open(   $input->open(
111          path => '/path/to/database/file',          path => '/path/to/database/file',
112          code_page => 'cp852',          input_encoding => 'cp852',
113            strict_encoding => 0,
114          limit => 500,          limit => 500,
115          offset => 6000,          offset => 6000,
116          stats => 1,          stats => 1,
# Line 172  This function will read whole database i Line 123  This function will read whole database i
123                  901 => { '*' => { '^b' => ' ; ' } },                  901 => { '*' => { '^b' => ' ; ' } },
124          },          },
125          modify_file => 'conf/modify/mapping.map',          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<code_page> is assumed to be C<cp852>.  By default, C<input_encoding> is assumed to be C<cp852>.
139    
140  C<offset> is optional parametar to position at some offset before reading from database.  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  C<limit> is optional parametar to read just C<limit> records from database
143    
# Line 192  C<modify_file> is alternative for C<modi Line 153  C<modify_file> is alternative for C<modi
153  (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option  (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.  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>  Returns size of database, regardless of C<offset> and C<limit>
162  parametars, see also C<size>.  parametars, see also C<size>.
163    
# Line 202  sub open { Line 168  sub open {
168          my $arg = {@_};          my $arg = {@_};
169    
170          my $log = $self->_get_logger();          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});          $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}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
177                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
# Line 210  sub open { Line 179  sub open {
179          $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");          $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
180    
181          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
182          my $code_page = $arg->{'code_page'} || 'cp852';          my $input_encoding = $arg->{'input_encoding'} || $self->{'input_encoding'} || 'cp852';
183    
184          # store data in object          # store data in object
185          $self->{'input_code_page'} = $code_page;          $self->{$_} = $arg->{$_} foreach grep { defined $arg->{$_} } qw(path offset limit);
186          foreach my $v (qw/path offset limit/) {  
187                  $self->{$v} = $arg->{$v} if ($arg->{$v});          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;          my $filter_ref;
# Line 245  sub open { Line 221  sub open {
221                  $log->debug("using modify_file $p");                  $log->debug("using modify_file $p");
222                  $rec_regex = $self->modify_file_regexps( $p );                  $rec_regex = $self->modify_file_regexps( $p );
223          } elsif (my $h = $arg->{modify_records}) {          } elsif (my $h = $arg->{modify_records}) {
224                  $log->debug("using modify_records ", Dumper( $h ));                  $log->debug("using modify_records ", sub { dump( $h ) });
225                  $rec_regex = $self->modify_record_regexps(%{ $h });                  $rec_regex = $self->modify_record_regexps(%{ $h });
226          }          }
227          $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);          $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 ($db, $size) = $self->{open_db}->( $self,          my $ll_db = $class->new(
234                  path => $arg->{path},                  path => $arg->{path},
235                    input_config => $arg->{input_config} || $self->{input_config},
236  #               filter => sub {  #               filter => sub {
237  #                       my ($l,$f_nr) = @_;  #                       my ($l,$f_nr) = @_;
238  #                       return unless defined($l);  #                       return unless defined($l);
239  #                       from_to($l, $code_page, $self->{'encoding'});  #                       $l = decode($input_encoding, $l);
240  #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);  #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
241  #                       return $l;  #                       return $l;
242  #               },  #               },
243                  %{ $arg },                  %{ $arg },
244          );          );
245    
246          unless (defined($db)) {          # 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...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
251                  return;                  return;
252          }          }
253    
254            my $size = $ll_db->size;
255    
256          unless ($size) {          unless ($size) {
257                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
258                  return;                  return;
# Line 276  sub open { Line 262  sub open {
262          my $to_rec = $size;          my $to_rec = $size;
263    
264          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
265                  $log->debug("skipping to MFN $s");                  $log->debug("offset $s records");
266                  $from_rec = $s;                  $from_rec = $s + 1;
267          } else {          } else {
268                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec - 1;
269          }          }
270    
271          if ($self->{limit}) {          if ($self->{limit}) {
# Line 288  sub open { Line 274  sub open {
274                  $to_rec = $size if ($to_rec > $size);                  $to_rec = $size if ($to_rec > $size);
275          }          }
276    
277          # store size for later          my $strict_encoding = $arg->{strict_encoding} || $self->{strict_encoding}; ## FIXME should be 1 really
278          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;  
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          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');          $self->{size} = 0;
285    
286          # read database          # read database
287          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
288    
289                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
290    
291                  my $rec = $self->{fetch_rec}->($self, $pos, sub {                  $self->{size}++; # XXX I could move this more down if I didn't want empty records...
292                                  my ($l,$f_nr) = @_;  
293                    my $rec = $ll_db->fetch_rec($pos, sub {
294                                    my ($l,$f_nr,$debug) = @_;
295  #                               return unless defined($l);  #                               return unless defined($l);
296  #                               return $l unless ($rec_regex && $f_nr);  #                               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");                                  $log->debug("-=> $f_nr ## $l");
302    
303                                  # codepage conversion and recode_regex                                  # codepage conversion and recode_regex
304                                  from_to($l, $code_page, $self->{'encoding'});                                  $l = decode($input_encoding, $l, 1);
305                                  $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);                                  $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
306    
307                                  # apply regexps                                  # apply regexps
# Line 315  sub open { Line 310  sub open {
310                                          my $c = 0;                                          my $c = 0;
311                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {
312                                                  my $old_l = $l;                                                  my $old_l = $l;
313                                                  eval '$l =~ ' . $r;                                                  $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
314                                                    eval '$l =~ ' . $r->{regex};
315                                                  if ($old_l ne $l) {                                                  if ($old_l ne $l) {
316                                                          $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");                                                          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: $r") if ($@);                                                  $log->error("error applying regex: ",dump($r), $@) if $@;
324                                          }                                          }
325                                  }                                  }
326    
327                                  $log->debug("<=- $f_nr ## $l");                                  $log->debug("<=- $f_nr ## |$l|");
328                                    warn "<=- $f_nr ## $l\n" if ($debug);
329                                  return $l;                                  return $l;
330                  });                  });
331    
332                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
333    
334                  if (! $rec) {                  if (! $rec) {
335                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 335  sub open { Line 337  sub open {
337                  }                  }
338    
339                  # store                  # store
340                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
341                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
342                                    id => $pos,
343                                    row => $rec,
344                            });
345                  } else {                  } else {
346                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
347                  }                  }
# Line 348  sub open { Line 353  sub open {
353                  if ($self->{stats}) {                  if ($self->{stats}) {
354    
355                          # fetch clean record with regexpes applied for statistics                          # fetch clean record with regexpes applied for statistics
356                          my $rec = $self->{fetch_rec}->($self, $pos);                          my $rec = $ll_db->fetch_rec($pos);
357    
358                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
359                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
360    
361                                  $log->logdie("invalid record fild $fld, not ARRAY")                                  #$log->logdie("invalid record fild $fld, not ARRAY")
362                                          unless (ref($rec->{ $fld }) eq 'ARRAY');                                  next unless (ref($rec->{ $fld }) eq 'ARRAY');
363                    
364                                  foreach my $row (@{ $rec->{$fld} }) {                                  foreach my $row (@{ $rec->{$fld} }) {
365    
# Line 388  sub open { Line 393  sub open {
393          return $size;          return $size;
394  }  }
395    
396    sub input_module { $_[0]->{ll_db} }
397    
398  =head2 fetch  =head2 fetch
399    
400  Fetch next record from database. It will also displays progress bar.  Fetch next record from database. It will also displays progress bar.
# Line 407  sub fetch { Line 414  sub fetch {
414          $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});          $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
415    
416          if ($self->{pos} == -1) {          if ($self->{pos} == -1) {
417                  $self->{pos} = $self->{offset};                  $self->{pos} = $self->{offset} + 1;
418          } else {          } else {
419                  $self->{pos}++;                  $self->{pos}++;
420          }          }
# Line 424  sub fetch { Line 431  sub fetch {
431    
432          my $rec;          my $rec;
433    
434          if ($self->{low_mem}) {          if ($self->{load_row}) {
435                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
436          } else {          } else {
437                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
438          }          }
# Line 465  because it takes into account C<offset> Line 472  because it takes into account C<offset>
472    
473  sub size {  sub size {
474          my $self = shift;          my $self = shift;
475          return $self->{size};          return $self->{size}; # FIXME this is buggy if open is called multiple times!
476  }  }
477    
478  =head2 seek  =head2 seek
# Line 480  First record in database has position 1. Line 487  First record in database has position 1.
487    
488  sub seek {  sub seek {
489          my $self = shift;          my $self = shift;
490          my $pos = shift || return;          my $pos = shift;
491    
492          my $log = $self->_get_logger();          my $log = $self->_get_logger();
493    
494            $log->logconfess("called without pos") unless defined($pos);
495    
496          if ($pos < 1) {          if ($pos < 1) {
497                  $log->warn("seek before first record");                  $log->warn("seek before first record");
498                  $pos = 1;                  $pos = 1;
# Line 518  sub stats { Line 527  sub stats {
527    
528          my $out = join("\n",          my $out = join("\n",
529                  map {                  map {
530                          my $f = $_ || die "no field";                          my $f = $_;
531                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
532                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
533                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
534    
535                          my $o = sprintf("%4s %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
536    
537                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
538                                    my @subfields = keys %{ $s->{sf}->{$f} };
539                                  map {                                  map {
540                                          $o .= sprintf(" %s:%d%s", $_,                                          $o .= sprintf(" %s:%d%s", $_,
541                                                  $s->{sf}->{$f}->{$_}->{count},                                                  $s->{sf}->{$f}->{$_}->{count},
542                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
543                                          );                                          );
544                                  } sort keys %{ $s->{sf}->{$f} };                                  } (
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}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 538  sub stats { Line 554  sub stats {
554                          }                          }
555    
556                          $o;                          $o;
557                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } 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 { Dumper($s) } );          $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;          return $out;
573  }  }
574    
575  =head2 dump  =head2 dump_ascii
576    
577  Display humanly readable dump of record  Display humanly readable dump of record
578    
579  =cut  =cut
580    
581  sub dump {  sub dump_ascii {
582          my $self = shift;          my $self = shift;
583    
584          return $self->{dump_rec}->($self, $self->{pos});          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 modify_record_regexps  =head2 _get_regex
594    
595  Generate hash with regexpes to be applied using l<filter>.  Helper function called which create regexps to be execute on code.
596    
597    my $regexpes = $input->modify_record_regexps(    _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
598                  900 => { '^a' => { ' : ' => '^b' } },    _get_regex( 900, '^b', ' : ^b' );
599                  901 => { '*' => { '^b' => ' ; ' } },  
600    );  It supports perl regexps with C<regex:> prefix to from value and has
601    additional logic to skip empty subfields.
602    
603  =cut  =cut
604    
605  sub _get_regex {  sub _get_regex {
606          my ($sf,$from,$to) = @_;          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 =~ /^\^/) {          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                  return
623                          's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';                          's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
624          } else {          } else {
625                  return                  return
626                          's/\Q'. $from .'\E/'. $to .'/g';                          '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 {  sub modify_record_regexps {
643          my $self = shift;          my $self = shift;
644          my $modify_record = {@_};          my $modify_record = {@_};
# Line 598  sub modify_record_regexps { Line 656  sub modify_record_regexps {
656                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
657                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
658                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
659                                  $log->debug("transform: |$from| -> |$to|");                                  my $d = "|$from| -> |$to|";
660                                    $log->debug("transform: $d");
661    
662                                  my $regex = _get_regex($sf,$from,$to);                                  my $regex = _get_regex($sf,$from,$to);
663                                  push @{ $regexpes->{$f} }, $regex;                                  push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
664                                  $log->debug("regex: $regex");                                  $log->debug("regex: $regex");
665                          }                          }
666                  }                  }
# Line 612  sub modify_record_regexps { Line 671  sub modify_record_regexps {
671    
672  =head2 modify_file_regexps  =head2 modify_file_regexps
673    
674  Generate hash with regexpes to be applied using l<filter> from  Generate hash with regexpes to be applied using L<filter> from
675  pseudo hash/yaml format for regex mappings.  pseudo hash/yaml format for regex mappings.
676    
677  It should be obvious:  It should be obvious:
# Line 662  sub modify_file_regexps { Line 721  sub modify_file_regexps {
721                          $log->debug("transform: |$from| -> |$to|");                          $log->debug("transform: |$from| -> |$to|");
722    
723                          my $regex = _get_regex($sf,$from,$to);                          my $regex = _get_regex($sf,$from,$to);
724                          push @{ $regexpes->{$f} }, $regex;                          push @{ $regexpes->{$f} }, {
725                                    regex => $regex,
726                                    file => $modify_path,
727                                    line => $.,
728                            };
729                          $log->debug("regex: $regex");                          $log->debug("regex: $regex");
730                    } else {
731                            die "can't parse: $_";
732                  }                  }
733          }          }
734    
735          return $regexpes;          return $regexpes;
736  }  }
737    
 =head1 MEMORY USAGE  
   
 C<low_mem> options is double-edged sword. If enabled, WebPAC  
 will run on memory constraint machines (which doesn't have enough  
 physical RAM to create memory structure for whole source database).  
   
 If your machine has 512Mb or more of RAM and database is around 10000 records,  
 memory shouldn't be an issue. If you don't have enough physical RAM, you  
 might consider using virtual memory (if your operating system is handling it  
 well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle  
 parsed structure of ISIS database (this is what C<low_mem> option does).  
   
 Hitting swap at end of reading source database is probably o.k. However,  
 hitting swap before 90% will dramatically decrease performance and you will  
 be better off with C<low_mem> and using rest of availble memory for  
 operating system disk cache (Linux is particuallary good about this).  
 However, every access to database record will require disk access, so  
 generation phase will be slower 10-100 times.  
   
 Parsed structures are essential - you just have option to trade RAM memory  
 (which is fast) for disk space (which is slow). Be sure to have planty of  
 disk space if you are using C<low_mem> and thus L<DBM::Deep>.  
   
 However, when WebPAC is running on desktop machines (or laptops :-), it's  
 highly undesireable for system to start swapping. Using C<low_mem> option can  
 reduce WecPAC memory usage to around 64Mb for same database with lookup  
 fields and sorted indexes which stay in RAM. Performance will suffer, but  
 memory usage will really be minimal. It might be also more confortable to  
 run WebPAC reniced on those machines.  
   
   
738  =head1 AUTHOR  =head1 AUTHOR
739    
740  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.707  
changed lines
  Added in v.1307
  ViewVC Help
Powered by ViewVC 1.1.26