/[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 483 by dpavlin, Sun May 14 09:34:05 2006 UTC revision 1236 by dpavlin, Fri Jul 10 13:54:55 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 WebPAC::Common 0.03;  use lib 'lib';
7    
8    use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Text::Iconv;  use Data::Dump qw/dump/;
11  use Data::Dumper;  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.04  
   
18  =cut  =cut
19    
20  our $VERSION = '0.04';  our $VERSION = '0.19';
21    
22  =head1 SYNOPSIS  =head1 SYNOPSIS
23    
# Line 37  C<fetch_rec> and optional C<init> functi Line 36  C<fetch_rec> and optional C<init> functi
36    
37  Perhaps a little code snippet.  Perhaps a little code snippet.
38    
39      use WebPAC::Input;          use WebPAC::Input;
40    
41      my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
42          module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
43                  config => $config,          );
                 lookup => $lookup_obj,  
                 low_mem => 1,  
     );  
44    
45      $db->open('/path/to/database');          $db->open( path => '/path/to/database' );
46          print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
47          while (my $rec = $db->fetch) {          while (my $rec = $db->fetch) {
48                  # do something with $rec                  # do something with $rec
# 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',
         code_page => '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<code_page> 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("specify low-level file format module") unless ($self->{module});          $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
89          my $module = $self->{module};          $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
90          $module =~ s#::#/#g;          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if $self->{lookup};
91          $module .= '.pm';          $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if $self->{low_mem};
         $log->debug("require low-level module $self->{module} from $module");  
   
         require $module;  
         #eval $self->{module} .'->import';  
   
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init/) {  
                 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->{'code_page'} ||= '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)");  
   
                 my $db_file = "data.db";  
   
                 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;  
92    
93                  my $db = new DBM::Deep $db_file;          $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                  $log->logdie("DBM::Deep error: $!") unless ($db);          require $module_path;
   
                 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 154  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 => '852',          input_encoding => 'cp852',
113            strict_encoding => 0,
114          limit => 500,          limit => 500,
115          offset => 6000,          offset => 6000,
116          lookup => $lookup_obj,          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<code_page> is assumed to be C<852>.  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 position at some offset before reading from database.
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    
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>  Returns size of database, regardless of C<offset> and C<limit>
162  parametars, see also C<size>.  parametars, see also C<size>.
163    
# Line 178  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});
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'});          $log->logcroak("need path") if (! $arg->{'path'});
182          my $code_page = $arg->{'code_page'} || '852';          my $input_encoding = $arg->{'input_encoding'} || $self->{'input_encoding'} || 'cp852';
183    
184          # store data in object          # store data in object
         $self->{'input_code_page'} = $code_page;  
185          foreach my $v (qw/path offset limit/) {          foreach my $v (qw/path offset limit/) {
186                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
187          }          }
188    
189          # create Text::Iconv object          if ($arg->{load_row} || $arg->{save_row}) {
190          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});                  $log->logconfess("save_row and load_row must be defined in pair and be CODE") unless (
191                            ref($arg->{load_row}) eq 'CODE' &&
192                            ref($arg->{save_row}) eq 'CODE'
193                    );
194                    $self->{load_row} = $arg->{load_row};
195                    $self->{save_row} = $arg->{save_row};
196                    $log->debug("using load_row and save_row instead of in-memory hash");
197            }
198    
199          my $filter_ref;          my $filter_ref;
200            my $recode_regex;
201            my $recode_map;
202    
203          if ($self->{recode}) {          if ($self->{recode}) {
204                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
205                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
206                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");
207                  } else {                  } else {
                         my $recode;  
208                          while (@r) {                          while (@r) {
209                                  my $from = shift @r;                                  my $from = shift @r;
210                                  my $to = shift @r;                                  my $to = shift @r;
211                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
212                          }                          }
213    
214                          my $regex = join '|' => keys %{ $recode };                          $recode_regex = join '|' => keys %{ $recode_map };
   
                         $log->debug("using recode regex: $regex");  
                           
                         $filter_ref = sub {  
                                 my $t = shift;  
                                 $t =~ s/($regex)/$recode->{$1}/g;  
                                 return $t;  
                         };  
215    
216                            $log->debug("using recode regex: $recode_regex");
217                  }                  }
218    
219          }          }
220    
221          my ($db, $size) = $self->{open_db}->( $self,          my $rec_regex;
222            if (my $p = $arg->{modify_file}) {
223                    $log->debug("using modify_file $p");
224                    $rec_regex = $self->modify_file_regexps( $p );
225            } elsif (my $h = $arg->{modify_records}) {
226                    $log->debug("using modify_records ", sub { dump( $h ) });
227                    $rec_regex = $self->modify_record_regexps(%{ $h });
228            }
229            $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
230    
231            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
232    
233            my $ll_db = $class->new(
234                  path => $arg->{path},                  path => $arg->{path},
235                  filter => $filter_ref,                  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          unless ($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 238  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->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
266                  $from_rec = $s;                  $from_rec = $s;
267          } else {          } else {
268                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec;
# Line 253  sub open { Line 277  sub open {
277          # store size for later          # store size for later
278          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
279    
280          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}");          my $strict_encoding = $arg->{strict_encoding} || $self->{strict_encoding}; ## FIXME should be 1 really
281    
282            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec]",
283                    " encoding $input_encoding ", $strict_encoding ? ' [strict]' : '',
284                    $self->{stats} ? ' [stats]' : '',
285            );
286    
287          # read database          # read database
288          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
289    
290                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
291    
292                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
293                                    my ($l,$f_nr,$debug) = @_;
294    #                               return unless defined($l);
295    #                               return $l unless ($rec_regex && $f_nr);
296    
297                                    return unless ( defined($l) && defined($f_nr) );
298    
299                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
300                                    $log->debug("-=> $f_nr ## $l");
301    
302                                    # codepage conversion and recode_regex
303                                    $l = decode($input_encoding, $l, 1);
304                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
305    
306                                    # apply regexps
307                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
308                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
309                                            my $c = 0;
310                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
311                                                    my $old_l = $l;
312                                                    $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
313                                                    eval '$l =~ ' . $r->{regex};
314                                                    if ($old_l ne $l) {
315                                                            my $d = "|$old_l| -> |$l| "; # . $r->{regex};
316                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
317                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
318                                                            $log->debug("MODIFY $d");
319                                                            warn "*** $d\n" if ($debug);
320    
321                                                    }
322                                                    $log->error("error applying regex: ",dump($r), $@) if $@;
323                                            }
324                                    }
325    
326                                    $log->debug("<=- $f_nr ## |$l|");
327                                    warn "<=- $f_nr ## $l\n" if ($debug);
328                                    return $l;
329                    });
330    
331                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
332    
333                  if (! $rec) {                  if (! $rec) {
334                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 270  sub open { Line 336  sub open {
336                  }                  }
337    
338                  # store                  # store
339                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
340                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
341                                    id => $pos,
342                                    row => $rec,
343                            });
344                  } else {                  } else {
345                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
346                  }                  }
347    
348                  # create lookup                  # create lookup
349                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
350    
351                    # update counters for statistics
352                    if ($self->{stats}) {
353    
354                            # fetch clean record with regexpes applied for statistics
355                            my $rec = $ll_db->fetch_rec($pos);
356    
357                            foreach my $fld (keys %{ $rec }) {
358                                    $self->{_stats}->{fld}->{ $fld }++;
359    
360                                    #$log->logdie("invalid record fild $fld, not ARRAY")
361                                    next unless (ref($rec->{ $fld }) eq 'ARRAY');
362            
363                                    foreach my $row (@{ $rec->{$fld} }) {
364    
365                                            if (ref($row) eq 'HASH') {
366    
367                                                    foreach my $sf (keys %{ $row }) {
368                                                            next if ($sf eq 'subfields');
369                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
370                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
371                                                                            if (ref($row->{$sf}) eq 'ARRAY');
372                                                    }
373    
374                                            } else {
375                                                    $self->{_stats}->{repeatable}->{ $fld }++;
376                                            }
377                                    }
378                            }
379                    }
380    
381                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
382    
# Line 293  sub open { Line 392  sub open {
392          return $size;          return $size;
393  }  }
394    
395    sub input_module { $_[0]->{ll_db} }
396    
397  =head2 fetch  =head2 fetch
398    
399  Fetch next record from database. It will also displays progress bar.  Fetch next record from database. It will also displays progress bar.
# Line 329  sub fetch { Line 430  sub fetch {
430    
431          my $rec;          my $rec;
432    
433          if ($self->{low_mem}) {          if ($self->{load_row}) {
434                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
435          } else {          } else {
436                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
437          }          }
# Line 385  First record in database has position 1. Line 486  First record in database has position 1.
486    
487  sub seek {  sub seek {
488          my $self = shift;          my $self = shift;
489          my $pos = shift || return;          my $pos = shift;
490    
491          my $log = $self->_get_logger();          my $log = $self->_get_logger();
492    
493            $log->logconfess("called without pos") unless defined($pos);
494    
495          if ($pos < 1) {          if ($pos < 1) {
496                  $log->warn("seek before first record");                  $log->warn("seek before first record");
497                  $pos = 1;                  $pos = 1;
# Line 400  sub seek { Line 503  sub seek {
503          return $self->{pos} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
504  }  }
505    
506    =head2 stats
507    
508    Dump statistics about field and subfield usage
509    
510      print $input->stats;
511    
512    =cut
513    
514    sub stats {
515            my $self = shift;
516    
517            my $log = $self->_get_logger();
518    
519            my $s = $self->{_stats};
520            if (! $s) {
521                    $log->warn("called stats, but there is no statistics collected");
522                    return;
523            }
524    
525            my $max_fld = 0;
526    
527            my $out = join("\n",
528                    map {
529                            my $f = $_;
530                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
531                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
532                            $max_fld = $v if ($v > $max_fld);
533    
534                            my $o = sprintf("%4s %d ~", $f, $v);
535    
536                            if (defined($s->{sf}->{$f})) {
537                                    my @subfields = keys %{ $s->{sf}->{$f} };
538                                    map {
539                                            $o .= sprintf(" %s:%d%s", $_,
540                                                    $s->{sf}->{$f}->{$_}->{count},
541                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
542                                            );
543                                    } (
544                                            # first indicators and other special subfields
545                                            sort( grep { length($_)  > 1 } @subfields ),
546                                            # then subfileds (single char)
547                                            sort( grep { length($_) == 1 } @subfields ),
548                                    );
549                            }
550    
551                            if (my $v_r = $s->{repeatable}->{$f}) {
552                                    $o .= " ($v_r)" if ($v_r != $v);
553                            }
554    
555                            $o;
556                    } sort {
557                            if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
558                                    $a <=> $b
559                            } else {
560                                    $a cmp $b
561                            }
562                    } keys %{ $s->{fld} }
563            );
564    
565            $log->debug( sub { dump($s) } );
566    
567            my $path = 'var/stats.yml';
568            YAML::DumpFile( $path, $s );
569            $log->info( 'created ', $path, ' with ', -s $path, ' bytes' );
570    
571            return $out;
572    }
573    
574    =head2 dump_ascii
575    
576    Display humanly readable dump of record
577    
578    =cut
579    
580    sub dump_ascii {
581            my $self = shift;
582    
583            return unless $self->{ll_db};
584    
585            if ($self->{ll_db}->can('dump_ascii')) {
586                    return $self->{ll_db}->dump_ascii( $self->{pos} );
587            } else {
588                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
589            }
590    }
591    
592    =head2 _get_regex
593    
594    Helper function called which create regexps to be execute on code.
595    
596      _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
597      _get_regex( 900, '^b', ' : ^b' );
598    
599    It supports perl regexps with C<regex:> prefix to from value and has
600    additional logic to skip empty subfields.
601    
602    =cut
603    
604    sub _get_regex {
605            my ($sf,$from,$to) = @_;
606    
607            # protect /
608            $from =~ s!/!\\/!gs;
609            $to =~ s!/!\\/!gs;
610    
611            if ($from =~ m/^regex:(.+)$/) {
612                    $from = $1;
613            } else {
614                    $from = '\Q' . $from . '\E';
615            }
616            if ($sf =~ /^\^/) {
617                    my $need_subfield_data = '*';   # no
618                    # if from is also subfield, require some data in between
619                    # to correctly skip empty subfields
620                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
621                    return
622                            's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
623            } else {
624                    return
625                            's/'. $from .'/'. $to .'/g';
626            }
627    }
628    
629    
630    =head2 modify_record_regexps
631    
632  =head1 MEMORY USAGE  Generate hash with regexpes to be applied using L<filter>.
633    
634      my $regexpes = $input->modify_record_regexps(
635                    900 => { '^a' => { ' : ' => '^b' } },
636                    901 => { '*' => { '^b' => ' ; ' } },
637      );
638    
639    =cut
640    
641    sub modify_record_regexps {
642            my $self = shift;
643            my $modify_record = {@_};
644    
645  C<low_mem> options is double-edged sword. If enabled, WebPAC          my $regexpes;
 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.  
646    
647            my $log = $self->_get_logger();
648    
649            foreach my $f (keys %$modify_record) {
650                    $log->debug("field: $f");
651    
652                    foreach my $sf (keys %{ $modify_record->{$f} }) {
653                            $log->debug("subfield: $sf");
654    
655                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
656                                    my $to = $modify_record->{$f}->{$sf}->{$from};
657                                    #die "no field?" unless defined($to);
658                                    my $d = "|$from| -> |$to|";
659                                    $log->debug("transform: $d");
660    
661                                    my $regex = _get_regex($sf,$from,$to);
662                                    push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
663                                    $log->debug("regex: $regex");
664                            }
665                    }
666            }
667    
668            return $regexpes;
669    }
670    
671    =head2 modify_file_regexps
672    
673    Generate hash with regexpes to be applied using L<filter> from
674    pseudo hash/yaml format for regex mappings.
675    
676    It should be obvious:
677    
678            200
679              '^a'
680                ' : ' => '^e'
681                ' = ' => '^d'
682    
683    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
684    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
685    
686      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
687    
688    On undef path it will just return.
689    
690    =cut
691    
692    sub modify_file_regexps {
693            my $self = shift;
694    
695            my $modify_path = shift || return;
696    
697            my $log = $self->_get_logger();
698    
699            my $regexpes;
700    
701            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
702    
703            my ($f,$sf);
704    
705            while(<$fh>) {
706                    chomp;
707                    next if (/^#/ || /^\s*$/);
708    
709                    if (/^\s*(\d+)\s*$/) {
710                            $f = $1;
711                            $log->debug("field: $f");
712                            next;
713                    } elsif (/^\s*'([^']*)'\s*$/) {
714                            $sf = $1;
715                            $log->die("can't define subfiled before field in: $_") unless ($f);
716                            $log->debug("subfield: $sf");
717                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
718                            my ($from,$to) = ($1, $2);
719    
720                            $log->debug("transform: |$from| -> |$to|");
721    
722                            my $regex = _get_regex($sf,$from,$to);
723                            push @{ $regexpes->{$f} }, {
724                                    regex => $regex,
725                                    file => $modify_path,
726                                    line => $.,
727                            };
728                            $log->debug("regex: $regex");
729                    } else {
730                            die "can't parse: $_";
731                    }
732            }
733    
734            return $regexpes;
735    }
736    
737  =head1 AUTHOR  =head1 AUTHOR
738    
# Line 438  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 740  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
740    
741  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
742    
743  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
744    
745  This program is free software; you can redistribute it and/or modify it  This program is free software; you can redistribute it and/or modify it
746  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.483  
changed lines
  Added in v.1236
  ViewVC Help
Powered by ViewVC 1.1.26