/[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 599 by dpavlin, Thu Jul 13 13:55:19 2006 UTC revision 1076 by dpavlin, Wed Nov 28 22:51:43 2007 UTC
# Line 7  use blib; Line 7  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 16  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.09  Version 0.18
20    
21  =cut  =cut
22    
23  our $VERSION = '0.09';  our $VERSION = '0.18';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 43  Perhaps a little code snippet. Line 43  Perhaps a little code snippet.
43    
44          my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
45                  module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
                 low_mem => 1,  
46          );          );
47    
48          $db->open( path => '/path/to/database' );          $db->open( path => '/path/to/database' );
# Line 63  Create new input database object. Line 62  Create new input database object.
62    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
63          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
64          encoding => '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
# Line 75  Optional parametar C<encoding> specify a Line 76  Optional parametar C<encoding> specify a
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 96  sub new { Line 95  sub new {
95    
96          $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. change it to encoding") if ($self->{lookup});
97          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
98            $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if ($self->{low_mem});
99    
100          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
101          my $module = $self->{module};          my $module_path = $self->{module};
102          $module =~ s#::#/#g;          $module_path =~ s#::#/#g;
103          $module .= '.pm';          $module_path .= '.pm';
104          $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/) {  
                 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 };  
                 }  
         }  
105    
106          if ($self->{init}) {          require $module_path;
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
         }  
107    
108          $self->{'encoding'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
109    
         # 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;  
   
                 $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;  
         }  
   
110          $self ? return $self : return undef;          $self ? return $self : return undef;
111  }  }
112    
# Line 157  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_ref => sub {          lookup_coderef => sub {
126                  my ($k,$v) = @_;                  my $rec = shift;
127                  # store lookup $k => $v                  # store lookups
128          },          },
129          modify_records => {          modify_records => {
130                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
131                  901 => { '*' => { '^b' => ' ; ' } },                  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 182  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 call when adding C<< key => 'value' >> combinations to  C<lookup_coderef> is closure to called to save data into lookups
 lookup.  
155    
156  C<modify_records> specify mapping from subfields to delimiters or from  C<modify_records> specify mapping from subfields to delimiters or from
157  delimiters to subfields, as well as oprations on fields (if subfield is  delimiters to subfields, as well as oprations on fields (if subfield is
158  defined as C<*>.  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 204  sub open { Line 179  sub open {
179          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
180                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  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 213  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->{'encoding'});      ## FIXME remove!                  $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;          my $recode_regex;
# Line 238  sub open { Line 222  sub open {
222    
223          }          }
224    
225          my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });          my $rec_regex;
226          $log->debug("rec_regex: ", Dumper($rec_regex));          if (my $p = $arg->{modify_file}) {
227                    $log->debug("using modify_file $p");
228          my ($db, $size) = $self->{open_db}->( $self,                  $rec_regex = $self->modify_file_regexps( $p );
229                  path => $arg->{path},          } elsif (my $h = $arg->{modify_records}) {
230                  filter => sub {                  $log->debug("using modify_records ", sub { dump( $h ) });
231                                  my ($l,$f_nr) = @_;                  $rec_regex = $self->modify_record_regexps(%{ $h });
232                                  return unless defined($l);          }
233            $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
                                 ## FIXME remove iconv!  
                                 $l = $self->{iconv}->convert($l) if ($self->{iconv});  
           
                                 $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);  
   
                                 ## FIXME remove this warning when we are sure that none of API is calling  
                                 ## this wrongly  
                                 warn "filter called without field number" unless ($f_nr);  
234    
235                                  return $l unless ($rec_regex && $f_nr);          my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
236    
237                                  # apply regexps          my $ll_db = $class->new(
238                                  if ($rec_regex && defined($rec_regex->{$f_nr})) {                  path => $arg->{path},
239                                          $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');                  input_config => $arg->{input_config} || $self->{input_config},
240                                          my $c = 0;  #               filter => sub {
241                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {  #                       my ($l,$f_nr) = @_;
242                                                  while ( eval '$l =~ ' . $r ) { $c++ };  #                       return unless defined($l);
243                                          }  #                       from_to($l, $code_page, $self->{'encoding'});
244                                          warn "## field $f_nr triggered $c regexpes\n" if ($c && $self->{debug});  #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
245                                  }  #                       return $l;
246    #               },
                                 return $l;  
                 },  
247                  %{ $arg },                  %{ $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 309  sub open { Line 285  sub open {
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                  $log->debug(sub { Dumper($rec) });                                  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 { dump($rec) });
328    
329                  if (! $rec) {                  if (! $rec) {
330                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 319  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                  }                  }
# Line 331  sub open { Line 347  sub open {
347                  # update counters for statistics                  # update counters for statistics
348                  if ($self->{stats}) {                  if ($self->{stats}) {
349    
350                            # fetch clean record with regexpes applied for statistics
351                            my $rec = $ll_db->fetch_rec($pos);
352    
353                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
354                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
355    
356                                  $log->logdie("invalid record fild $fld, not ARRAY")                                  #$log->logdie("invalid record fild $fld, not ARRAY")
357                                          unless (ref($rec->{ $fld }) eq 'ARRAY');                                  next unless (ref($rec->{ $fld }) eq 'ARRAY');
358                    
359                                  foreach my $row (@{ $rec->{$fld} }) {                                  foreach my $row (@{ $rec->{$fld} }) {
360    
361                                          if (ref($row) eq 'HASH') {                                          if (ref($row) eq 'HASH') {
362    
363                                                  foreach my $sf (keys %{ $row }) {                                                  foreach my $sf (keys %{ $row }) {
364                                                            next if ($sf eq 'subfields');
365                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
366                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
367                                                                          if (ref($row->{$sf}) eq 'ARRAY');                                                                          if (ref($row->{$sf}) eq 'ARRAY');
# Line 365  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 404  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 460  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 498  sub stats { Line 523  sub stats {
523    
524          my $out = join("\n",          my $out = join("\n",
525                  map {                  map {
526                          my $f = $_ || die "no field";                          my $f = $_;
527                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
528                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
529                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
530    
531                          my $o = sprintf("%4s %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
532    
533                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
534                                    my @subfields = keys %{ $s->{sf}->{$f} };
535                                  map {                                  map {
536                                          $o .= sprintf(" %s:%d%s", $_,                                          $o .= sprintf(" %s:%d%s", $_,
537                                                  $s->{sf}->{$f}->{$_}->{count},                                                  $s->{sf}->{$f}->{$_}->{count},
538                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
539                                          );                                          );
540                                  } sort keys %{ $s->{sf}->{$f} };                                  } (
541                                            # first indicators and other special subfields
542                                            sort( grep { length($_)  > 1 } @subfields ),
543                                            # then subfileds (single char)
544                                            sort( grep { length($_) == 1 } @subfields ),
545                                    );
546                          }                          }
547    
548                          if (my $v_r = $s->{repeatable}->{$f}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 518  sub stats { Line 550  sub stats {
550                          }                          }
551    
552                          $o;                          $o;
553                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort {
554                            if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
555                                    $a <=> $b
556                            } else {
557                                    $a cmp $b
558                            }
559                    } keys %{ $s->{fld} }
560          );          );
561    
562          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
563    
564          return $out;          return $out;
565  }  }
566    
567    =head2 dump_ascii
568    
569    Display humanly readable dump of record
570    
571    =cut
572    
573    sub dump_ascii {
574            my $self = shift;
575    
576            return unless $self->{ll_db};
577    
578            if ($self->{ll_db}->can('dump_ascii')) {
579                    return $self->{ll_db}->dump_ascii( $self->{pos} );
580            } else {
581                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
582            }
583    }
584    
585    =head2 _get_regex
586    
587    Helper function called which create regexps to be execute on code.
588    
589      _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
590      _get_regex( 900, '^b', ' : ^b' );
591    
592    It supports perl regexps with C<regex:> prefix to from value and has
593    additional logic to skip empty subfields.
594    
595    =cut
596    
597    sub _get_regex {
598            my ($sf,$from,$to) = @_;
599    
600            # protect /
601            $from =~ s!/!\\/!gs;
602            $to =~ s!/!\\/!gs;
603    
604            if ($from =~ m/^regex:(.+)$/) {
605                    $from = $1;
606            } else {
607                    $from = '\Q' . $from . '\E';
608            }
609            if ($sf =~ /^\^/) {
610                    my $need_subfield_data = '*';   # no
611                    # if from is also subfield, require some data in between
612                    # to correctly skip empty subfields
613                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
614                    return
615                            's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
616            } else {
617                    return
618                            's/'. $from .'/'. $to .'/g';
619            }
620    }
621    
622    
623  =head2 modify_record_regexps  =head2 modify_record_regexps
624    
625  Generate hash with regexpes to be applied using L<filter>.  Generate hash with regexpes to be applied using L<filter>.
# Line 543  sub modify_record_regexps { Line 637  sub modify_record_regexps {
637    
638          my $regexpes;          my $regexpes;
639    
640            my $log = $self->_get_logger();
641    
642          foreach my $f (keys %$modify_record) {          foreach my $f (keys %$modify_record) {
643  warn "--- f: $f\n";                  $log->debug("field: $f");
644    
645                  foreach my $sf (keys %{ $modify_record->{$f} }) {                  foreach my $sf (keys %{ $modify_record->{$f} }) {
646  warn "---- sf: $sf\n";                          $log->debug("subfield: $sf");
647    
648                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
649                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
650                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
651  warn "----- transform: |$from| -> |$to|\n";                                  my $d = "|$from| -> |$to|";
652                                    $log->debug("transform: $d");
                                 if ($sf =~ /^\^/) {  
                                         my $regex =  
                                                 's/\Q'. $sf .'\E([^\^]+)\Q'. $from .'\E([^\^]+)/'. $sf .'$1'. $to .'$2/g';  
                                         push @{ $regexpes->{$f} }, $regex;  
 warn ">>>>> $regex [sf]\n";  
                                 } else {  
                                         my $regex =  
                                                 's/\Q'. $from .'\E/'. $to .'/g';  
                                         push @{ $regexpes->{$f} }, $regex;  
 warn ">>>>> $regex [global]\n";  
                                 }  
653    
654                                    my $regex = _get_regex($sf,$from,$to);
655                                    push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
656                                    $log->debug("regex: $regex");
657                          }                          }
658                  }                  }
659          }          }
# Line 571  warn ">>>>> $regex [global]\n"; Line 661  warn ">>>>> $regex [global]\n";
661          return $regexpes;          return $regexpes;
662  }  }
663    
664  =head1 MEMORY USAGE  =head2 modify_file_regexps
665    
666    Generate hash with regexpes to be applied using L<filter> from
667    pseudo hash/yaml format for regex mappings.
668    
669    It should be obvious:
670    
671  C<low_mem> options is double-edged sword. If enabled, WebPAC          200
672  will run on memory constraint machines (which doesn't have enough            '^a'
673  physical RAM to create memory structure for whole source database).              ' : ' => '^e'
674                ' = ' => '^d'
675  If your machine has 512Mb or more of RAM and database is around 10000 records,  
676  memory shouldn't be an issue. If you don't have enough physical RAM, you  In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
677  might consider using virtual memory (if your operating system is handling it  In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
678  well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle  
679  parsed structure of ISIS database (this is what C<low_mem> option does).    my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
680    
681  Hitting swap at end of reading source database is probably o.k. However,  On undef path it will just return.
682  hitting swap before 90% will dramatically decrease performance and you will  
683  be better off with C<low_mem> and using rest of availble memory for  =cut
684  operating system disk cache (Linux is particuallary good about this).  
685  However, every access to database record will require disk access, so  sub modify_file_regexps {
686  generation phase will be slower 10-100 times.          my $self = shift;
   
 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.  
687    
688            my $modify_path = shift || return;
689    
690            my $log = $self->_get_logger();
691    
692            my $regexpes;
693    
694            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
695    
696            my ($f,$sf);
697    
698            while(<$fh>) {
699                    chomp;
700                    next if (/^#/ || /^\s*$/);
701    
702                    if (/^\s*(\d+)\s*$/) {
703                            $f = $1;
704                            $log->debug("field: $f");
705                            next;
706                    } elsif (/^\s*'([^']*)'\s*$/) {
707                            $sf = $1;
708                            $log->die("can't define subfiled before field in: $_") unless ($f);
709                            $log->debug("subfield: $sf");
710                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
711                            my ($from,$to) = ($1, $2);
712    
713                            $log->debug("transform: |$from| -> |$to|");
714    
715                            my $regex = _get_regex($sf,$from,$to);
716                            push @{ $regexpes->{$f} }, {
717                                    regex => $regex,
718                                    file => $modify_path,
719                                    line => $.,
720                            };
721                            $log->debug("regex: $regex");
722                    }
723            }
724    
725            return $regexpes;
726    }
727    
728  =head1 AUTHOR  =head1 AUTHOR
729    
Legend:
Removed from v.599  
changed lines
  Added in v.1076
  ViewVC Help
Powered by ViewVC 1.1.26