/[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 506 by dpavlin, Mon May 15 09:59:05 2006 UTC revision 868 by dpavlin, Thu Jun 21 21:26:17 2007 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;
7    
8  use WebPAC::Common;  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/from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
# Line 14  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.05  Version 0.18
20    
21  =cut  =cut
22    
23  our $VERSION = '0.05';  our $VERSION = '0.18';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 37  C<fetch_rec> and optional C<init> functi Line 39  C<fetch_rec> and optional C<init> functi
39    
40  Perhaps a little code snippet.  Perhaps a little code snippet.
41    
42      use WebPAC::Input;          use WebPAC::Input;
43    
44      my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
45          module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
46                  config => $config,          );
                 lookup => $lookup_obj,  
                 low_mem => 1,  
     );  
47    
48      $db->open('/path/to/database');          $db->open( path => '/path/to/database' );
49          print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
50          while (my $rec = $db->fetch) {          while (my $rec = $db->fetch) {
51                  # do something with $rec                  # do something with $rec
# Line 62  Create new input database object. Line 61  Create new input database object.
61    
62    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
63          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
64          code_page => 'ISO-8859-2',          encoding => 'ISO-8859-2',
         low_mem => 1,  
65          recode => 'char pairs',          recode => 'char pairs',
66          no_progress_bar => 1,          no_progress_bar => 1,
67            input_config => {
68                    mapping => [ 'foo', 'bar', 'baz' ],
69            },
70    );    );
71    
72  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
73  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
74    
75  Optional parametar C<code_page> specify application code page (which will be  Optional parametar C<encoding> specify application code page (which will be
76  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
77  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
78    
 Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  
   
79  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
80  should be replaced in input stream.  should be replaced in input stream.
81    
# Line 94  sub new { Line 93  sub new {
93    
94          my $log = $self->_get_logger;          my $log = $self->_get_logger;
95    
96          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
97          my $module = $self->{module};          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
98          $module =~ s#::#/#g;          $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if ($self->{low_mem});
         $module .= '.pm';  
         $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;  
   
                 my $db = new DBM::Deep $db_file;  
99    
100                  $log->logdie("DBM::Deep error: $!") unless ($db);          $log->logconfess("specify low-level file format module") unless ($self->{module});
101            my $module_path = $self->{module};
102            $module_path =~ s#::#/#g;
103            $module_path .= '.pm';
104            $log->debug("require low-level module $self->{module} from $module_path");
105    
106                  if ($db->error()) {          require $module_path;
                         $log->logdie("can't open '$db_file' under low_mem: ",$db->error());  
                 } else {  
                         $log->debug("using file '$db_file' for DBM::Deep");  
                 }  
107    
108                  $self->{'db'} = $db;          $self->{'encoding'} ||= 'ISO-8859-2';
         }  
109    
110          $self ? return $self : return undef;          $self ? return $self : return undef;
111  }  }
# Line 154  sub new { Line 114  sub new {
114    
115  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
116    
117     my $store;     # simple in-memory hash
118    
119   $input->open(   $input->open(
120          path => '/path/to/database/file',          path => '/path/to/database/file',
121          code_page => '852',          code_page => 'cp852',
122          limit => 500,          limit => 500,
123          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
124          stats => 1,          stats => 1,
125            lookup_coderef => sub {
126                    my $rec = shift;
127                    # store lookups
128            },
129            modify_records => {
130                    900 => { '^a' => { ' : ' => '^b' } },
131                    901 => { '*' => { '^b' => ' ; ' } },
132            },
133            modify_file => 'conf/modify/mapping.map',
134            save_row => sub {
135                    my $a = shift;
136                    $store->{ $a->{id} } = $a->{row};
137            },
138            load_row => sub {
139                    my $a = shift;
140                    return defined($store->{ $a->{id} }) &&
141                            $store->{ $a->{id} };
142            },
143    
144   );   );
145    
146  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
147    
148  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.
149    
# Line 171  C<limit> is optional parametar to read j Line 151  C<limit> is optional parametar to read j
151    
152  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
153    
154    C<lookup_coderef> is closure to called to save data into lookups
155    
156    C<modify_records> specify mapping from subfields to delimiters or from
157    delimiters to subfields, as well as oprations on fields (if subfield is
158    defined as C<*>.
159    
160    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
161    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
162    overrides C<modify_records> if both exists for same input.
163    
164    C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
165    is documented in example above.
166    
167  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
168  parametars, see also C<size>.  parametars, see also C<size>.
169    
# Line 182  sub open { Line 175  sub open {
175    
176          my $log = $self->_get_logger();          my $log = $self->_get_logger();
177    
178            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
179            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
180                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
181    
182            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
183    
184          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
185          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
186    
187          # store data in object          # store data in object
188          $self->{'input_code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
# Line 191  sub open { Line 190  sub open {
190                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
191          }          }
192    
193          # create Text::Iconv object          if ($arg->{load_row} || $arg->{save_row}) {
194          $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 (
195                            ref($arg->{load_row}) eq 'CODE' &&
196                            ref($arg->{save_row}) eq 'CODE'
197                    );
198                    $self->{load_row} = $arg->{load_row};
199                    $self->{save_row} = $arg->{save_row};
200                    $log->debug("using load_row and save_row instead of in-memory hash");
201            }
202    
203          my $filter_ref;          my $filter_ref;
204            my $recode_regex;
205            my $recode_map;
206    
207          if ($self->{recode}) {          if ($self->{recode}) {
208                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
209                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
210                          $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)");
211                  } else {                  } else {
                         my $recode;  
212                          while (@r) {                          while (@r) {
213                                  my $from = shift @r;                                  my $from = shift @r;
214                                  my $to = shift @r;                                  my $to = shift @r;
215                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
216                          }                          }
217    
218                          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;  
                         };  
219    
220                            $log->debug("using recode regex: $recode_regex");
221                  }                  }
222    
223          }          }
224    
225          my ($db, $size) = $self->{open_db}->( $self,          my $rec_regex;
226            if (my $p = $arg->{modify_file}) {
227                    $log->debug("using modify_file $p");
228                    $rec_regex = $self->modify_file_regexps( $p );
229            } elsif (my $h = $arg->{modify_records}) {
230                    $log->debug("using modify_records ", sub { dump( $h ) });
231                    $rec_regex = $self->modify_record_regexps(%{ $h });
232            }
233            $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
234    
235            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
236    
237            my $ll_db = $class->new(
238                  path => $arg->{path},                  path => $arg->{path},
239                  filter => $filter_ref,                  input_config => $arg->{input_config},
240    #               filter => sub {
241    #                       my ($l,$f_nr) = @_;
242    #                       return unless defined($l);
243    #                       from_to($l, $code_page, $self->{'encoding'});
244    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
245    #                       return $l;
246    #               },
247                    %{ $arg },
248          );          );
249    
250          unless (defined($db)) {          unless (defined($ll_db)) {
251                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
252                  return;                  return;
253          }          }
254    
255            my $size = $ll_db->size;
256    
257          unless ($size) {          unless ($size) {
258                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
259                  return;                  return;
# Line 241  sub open { Line 263  sub open {
263          my $to_rec = $size;          my $to_rec = $size;
264    
265          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
266                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
267                  $from_rec = $s;                  $from_rec = $s;
268          } else {          } else {
269                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec;
# Line 256  sub open { Line 278  sub open {
278          # store size for later          # store size for later
279          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
280    
281          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}", $self->{stats} ? ' [stats]' : '');          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
282    
283          # read database          # read database
284          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
285    
286                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
287    
288                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
289                                    my ($l,$f_nr,$debug) = @_;
290    #                               return unless defined($l);
291    #                               return $l unless ($rec_regex && $f_nr);
292    
293                                    return unless ( defined($l) && defined($f_nr) );
294    
295                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
296                                    $log->debug("-=> $f_nr ## $l");
297    
298                                    # codepage conversion and recode_regex
299                                    from_to($l, $code_page, $self->{'encoding'});
300                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
301    
302                                    # apply regexps
303                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
304                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
305                                            my $c = 0;
306                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
307                                                    my $old_l = $l;
308                                                    $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
309                                                    eval '$l =~ ' . $r->{regex};
310                                                    if ($old_l ne $l) {
311                                                            my $d = "|$old_l| -> |$l| "; # . $r->{regex};
312                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
313                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
314                                                            $log->debug("MODIFY $d");
315                                                            warn "*** $d\n" if ($debug);
316    
317                                                    }
318                                                    $log->error("error applying regex: $r") if ($@);
319                                            }
320                                    }
321    
322                                    $log->debug("<=- $f_nr ## |$l|");
323                                    warn "<=- $f_nr ## $l\n" if ($debug);
324                                    return $l;
325                    });
326    
327                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
328    
329                  if (! $rec) {                  if (! $rec) {
330                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 273  sub open { Line 332  sub open {
332                  }                  }
333    
334                  # store                  # store
335                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
336                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
337                                    id => $pos,
338                                    row => $rec,
339                            });
340                  } else {                  } else {
341                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
342                  }                  }
343    
344                  # create lookup                  # create lookup
345                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
346    
347                  # update counters for statistics                  # update counters for statistics
348                  if ($self->{stats}) {                  if ($self->{stats}) {
349                          map {  
350                                  my $fld = $_;                          # fetch clean record with regexpes applied for statistics
351                            my $rec = $ll_db->fetch_rec($pos);
352    
353                            foreach my $fld (keys %{ $rec }) {
354                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
355                                  if (ref($rec->{ $fld }) eq 'ARRAY') {  
356                                          map {                                  $log->logdie("invalid record fild $fld, not ARRAY")
357                                                  if (ref($_) eq 'HASH') {                                          unless (ref($rec->{ $fld }) eq 'ARRAY');
358                                                          map {          
359                                                                  $self->{_stats}->{sf}->{ $fld }->{ $_ }++;                                  foreach my $row (@{ $rec->{$fld} }) {
360                                                          } keys %{ $_ };  
361                                                  } else {                                          if (ref($row) eq 'HASH') {
362                                                          $self->{_stats}->{repeatable}->{ $fld }++;  
363                                                    foreach my $sf (keys %{ $row }) {
364                                                            next if ($sf eq 'subfields');
365                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
366                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
367                                                                            if (ref($row->{$sf}) eq 'ARRAY');
368                                                  }                                                  }
369                                          } @{ $rec->{$fld} };  
370                                            } else {
371                                                    $self->{_stats}->{repeatable}->{ $fld }++;
372                                            }
373                                  }                                  }
374                          } keys %{ $rec };                          }
375                  }                  }
376    
377                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
# Line 312  sub open { Line 385  sub open {
385          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
386          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
387    
388            # save for dump
389            $self->{ll_db} = $ll_db;
390    
391          return $size;          return $size;
392  }  }
393    
# Line 351  sub fetch { Line 427  sub fetch {
427    
428          my $rec;          my $rec;
429    
430          if ($self->{low_mem}) {          if ($self->{load_row}) {
431                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
432          } else {          } else {
433                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
434          }          }
# Line 407  First record in database has position 1. Line 483  First record in database has position 1.
483    
484  sub seek {  sub seek {
485          my $self = shift;          my $self = shift;
486          my $pos = shift || return;          my $pos = shift;
487    
488          my $log = $self->_get_logger();          my $log = $self->_get_logger();
489    
490            $log->logconfess("called without pos") unless defined($pos);
491    
492          if ($pos < 1) {          if ($pos < 1) {
493                  $log->warn("seek before first record");                  $log->warn("seek before first record");
494                  $pos = 1;                  $pos = 1;
# Line 426  sub seek { Line 504  sub seek {
504    
505  Dump statistics about field and subfield usage  Dump statistics about field and subfield usage
506    
507    print Dumper( $input->stats );    print $input->stats;
508    
509  =cut  =cut
510    
511  sub stats {  sub stats {
512          my $self = shift;          my $self = shift;
513          return $self->{_stats};  
514            my $log = $self->_get_logger();
515    
516            my $s = $self->{_stats};
517            if (! $s) {
518                    $log->warn("called stats, but there is no statistics collected");
519                    return;
520            }
521    
522            my $max_fld = 0;
523    
524            my $out = join("\n",
525                    map {
526                            my $f = $_;
527                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
528                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
529                            $max_fld = $v if ($v > $max_fld);
530    
531                            my $o = sprintf("%4s %d ~", $f, $v);
532    
533                            if (defined($s->{sf}->{$f})) {
534                                    map {
535                                            $o .= sprintf(" %s:%d%s", $_,
536                                                    $s->{sf}->{$f}->{$_}->{count},
537                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
538                                            );
539                                    } sort keys %{ $s->{sf}->{$f} };
540                            }
541    
542                            if (my $v_r = $s->{repeatable}->{$f}) {
543                                    $o .= " ($v_r)" if ($v_r != $v);
544                            }
545    
546                            $o;
547                    } sort { $a <=> $b } keys %{ $s->{fld} }
548            );
549    
550            $log->debug( sub { dump($s) } );
551    
552            return $out;
553    }
554    
555    =head2 dump_ascii
556    
557    Display humanly readable dump of record
558    
559    =cut
560    
561    sub dump_ascii {
562            my $self = shift;
563    
564            return unless $self->{ll_db};
565    
566            if ($self->{ll_db}->can('dump_ascii')) {
567                    return $self->{ll_db}->dump_ascii( $self->{pos} );
568            } else {
569                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
570            }
571    }
572    
573    =head2 _get_regex
574    
575    Helper function called which create regexps to be execute on code.
576    
577      _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
578      _get_regex( 900, '^b', ' : ^b' );
579    
580    It supports perl regexps with C<regex:> prefix to from value and has
581    additional logic to skip empty subfields.
582    
583    =cut
584    
585    sub _get_regex {
586            my ($sf,$from,$to) = @_;
587    
588            # protect /
589            $from =~ s!/!\\/!gs;
590            $to =~ s!/!\\/!gs;
591    
592            if ($from =~ m/^regex:(.+)$/) {
593                    $from = $1;
594            } else {
595                    $from = '\Q' . $from . '\E';
596            }
597            if ($sf =~ /^\^/) {
598                    my $need_subfield_data = '*';   # no
599                    # if from is also subfield, require some data in between
600                    # to correctly skip empty subfields
601                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
602                    return
603                            's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
604            } else {
605                    return
606                            's/'. $from .'/'. $to .'/g';
607            }
608  }  }
609    
 =head1 MEMORY USAGE  
610    
611  C<low_mem> options is double-edged sword. If enabled, WebPAC  =head2 modify_record_regexps
612  will run on memory constraint machines (which doesn't have enough  
613  physical RAM to create memory structure for whole source database).  Generate hash with regexpes to be applied using L<filter>.
614    
615  If your machine has 512Mb or more of RAM and database is around 10000 records,    my $regexpes = $input->modify_record_regexps(
616  memory shouldn't be an issue. If you don't have enough physical RAM, you                  900 => { '^a' => { ' : ' => '^b' } },
617  might consider using virtual memory (if your operating system is handling it                  901 => { '*' => { '^b' => ' ; ' } },
618  well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle    );
619  parsed structure of ISIS database (this is what C<low_mem> option does).  
620    =cut
621  Hitting swap at end of reading source database is probably o.k. However,  
622  hitting swap before 90% will dramatically decrease performance and you will  sub modify_record_regexps {
623  be better off with C<low_mem> and using rest of availble memory for          my $self = shift;
624  operating system disk cache (Linux is particuallary good about this).          my $modify_record = {@_};
625  However, every access to database record will require disk access, so  
626  generation phase will be slower 10-100 times.          my $regexpes;
627    
628  Parsed structures are essential - you just have option to trade RAM memory          my $log = $self->_get_logger();
629  (which is fast) for disk space (which is slow). Be sure to have planty of  
630  disk space if you are using C<low_mem> and thus L<DBM::Deep>.          foreach my $f (keys %$modify_record) {
631                    $log->debug("field: $f");
 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.  
632    
633                    foreach my $sf (keys %{ $modify_record->{$f} }) {
634                            $log->debug("subfield: $sf");
635    
636                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
637                                    my $to = $modify_record->{$f}->{$sf}->{$from};
638                                    #die "no field?" unless defined($to);
639                                    my $d = "|$from| -> |$to|";
640                                    $log->debug("transform: $d");
641    
642                                    my $regex = _get_regex($sf,$from,$to);
643                                    push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
644                                    $log->debug("regex: $regex");
645                            }
646                    }
647            }
648    
649            return $regexpes;
650    }
651    
652    =head2 modify_file_regexps
653    
654    Generate hash with regexpes to be applied using L<filter> from
655    pseudo hash/yaml format for regex mappings.
656    
657    It should be obvious:
658    
659            200
660              '^a'
661                ' : ' => '^e'
662                ' = ' => '^d'
663    
664    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
665    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
666    
667      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
668    
669    On undef path it will just return.
670    
671    =cut
672    
673    sub modify_file_regexps {
674            my $self = shift;
675    
676            my $modify_path = shift || return;
677    
678            my $log = $self->_get_logger();
679    
680            my $regexpes;
681    
682            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
683    
684            my ($f,$sf);
685    
686            while(<$fh>) {
687                    chomp;
688                    next if (/^#/ || /^\s*$/);
689    
690                    if (/^\s*(\d+)\s*$/) {
691                            $f = $1;
692                            $log->debug("field: $f");
693                            next;
694                    } elsif (/^\s*'([^']*)'\s*$/) {
695                            $sf = $1;
696                            $log->die("can't define subfiled before field in: $_") unless ($f);
697                            $log->debug("subfield: $sf");
698                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
699                            my ($from,$to) = ($1, $2);
700    
701                            $log->debug("transform: |$from| -> |$to|");
702    
703                            my $regex = _get_regex($sf,$from,$to);
704                            push @{ $regexpes->{$f} }, {
705                                    regex => $regex,
706                                    file => $modify_path,
707                                    line => $.,
708                            };
709                            $log->debug("regex: $regex");
710                    }
711            }
712    
713            return $regexpes;
714    }
715    
716  =head1 AUTHOR  =head1 AUTHOR
717    
# Line 472  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 719  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
719    
720  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
721    
722  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
723    
724  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
725  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.506  
changed lines
  Added in v.868
  ViewVC Help
Powered by ViewVC 1.1.26