/[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 597 by dpavlin, Thu Jul 13 11:54:33 2006 UTC revision 1107 by dpavlin, Mon Aug 4 21:47:27 2008 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/decode from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
15  WebPAC::Input - read different file formats into WebPAC  WebPAC::Input - read different file formats into WebPAC
16    
 =head1 VERSION  
   
 Version 0.08  
   
17  =cut  =cut
18    
19  our $VERSION = '0.08';  our $VERSION = '0.19';
20    
21  =head1 SYNOPSIS  =head1 SYNOPSIS
22    
# Line 43  Perhaps a little code snippet. Line 39  Perhaps a little code snippet.
39    
40          my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
41                  module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
                 low_mem => 1,  
42          );          );
43    
44          $db->open( path => '/path/to/database' );          $db->open( path => '/path/to/database' );
# Line 62  Create new input database object. Line 57  Create new input database object.
57    
58    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
59          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
         encoding => 'ISO-8859-2',  
         low_mem => 1,  
60          recode => 'char pairs',          recode => 'char pairs',
61          no_progress_bar => 1,          no_progress_bar => 1,
62            input_config => {
63                    mapping => [ 'foo', 'bar', 'baz' ],
64            },
65    );    );
66    
67  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
68  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
69    
 Optional parametar C<encoding> specify application code page (which will be  
 used internally). This should probably be your terminal encoding, and by  
 default, it C<ISO-8859-2>.  
   
 Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  
   
70  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
71  should be replaced in input stream.  should be replaced in input stream.
72    
# Line 94  sub new { Line 84  sub new {
84    
85          my $log = $self->_get_logger;          my $log = $self->_get_logger;
86    
87          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});          $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
88          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});          $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
89            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if $self->{lookup};
90            $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if $self->{low_mem};
91    
92          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
93          my $module = $self->{module};          my $module_path = $self->{module};
94          $module =~ s#::#/#g;          $module_path =~ s#::#/#g;
95          $module .= '.pm';          $module_path .= '.pm';
96          $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 };  
                 }  
         }  
   
         if ($self->{init}) {  
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
         }  
   
         $self->{'encoding'} ||= 'ISO-8859-2';  
   
         # running with low_mem flag? well, use DBM::Deep then.  
         if ($self->{'low_mem'}) {  
                 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");  
   
                 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;  
97    
98                  my $db = new DBM::Deep $db_file;          require $module_path;
   
                 $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;  
         }  
99    
100          $self ? return $self : return undef;          $self ? return $self : return undef;
101  }  }
# Line 157  sub new { Line 104  sub new {
104    
105  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
106    
107     my $store;     # simple in-memory hash
108    
109   $input->open(   $input->open(
110          path => '/path/to/database/file',          path => '/path/to/database/file',
111          code_page => '852',          input_encoding => 'cp852',
112            strict_encoding => 0,
113          limit => 500,          limit => 500,
114          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
115          stats => 1,          stats => 1,
116          lookup_ref => sub {          lookup_coderef => sub {
117                  my ($k,$v) = @_;                  my $rec = shift;
118                  # store lookup $k => $v                  # store lookups
119          },          },
120          modify_records => {          modify_records => {
121                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
122                  901 => { '*' => { '^b' => ' ; ' } },                  901 => { '*' => { '^b' => ' ; ' } },
123          },          },
124            modify_file => 'conf/modify/mapping.map',
125            save_row => sub {
126                    my $a = shift;
127                    $store->{ $a->{id} } = $a->{row};
128            },
129            load_row => sub {
130                    my $a = shift;
131                    return defined($store->{ $a->{id} }) &&
132                            $store->{ $a->{id} };
133            },
134    
135   );   );
136    
137  By default, C<code_page> is assumed to be C<852>.  By default, C<input_encoding> is assumed to be C<cp852>.
138    
139  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.
140    
# Line 182  C<limit> is optional parametar to read j Line 142  C<limit> is optional parametar to read j
142    
143  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
144    
145  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.  
146    
147  C<modify_records> specify mapping from subfields to delimiters or from  C<modify_records> specify mapping from subfields to delimiters or from
148  delimiters to subfields, as well as oprations on fields (if subfield is  delimiters to subfields, as well as oprations on fields (if subfield is
149  defined as C<*>.  defined as C<*>.
150    
151    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
152    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
153    overrides C<modify_records> if both exists for same input.
154    
155    C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
156    is documented in example above.
157    
158    C<strict_encoding> should really default to 1, but it doesn't for now.
159    
160  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
161  parametars, see also C<size>.  parametars, see also C<size>.
162    
# Line 199  sub open { Line 167  sub open {
167          my $arg = {@_};          my $arg = {@_};
168    
169          my $log = $self->_get_logger();          my $log = $self->_get_logger();
170            $log->debug( "arguments: ",dump( $arg ));
171    
172            $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
173            $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
174          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
175          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
176                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
177    
178            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
179    
180          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
181          my $code_page = $arg->{'code_page'} || '852';          my $input_encoding = $arg->{'input_encoding'} || $self->{'input_encoding'} || 'cp852';
182    
183          # store data in object          # store data in object
         $self->{'input_code_page'} = $code_page;  
184          foreach my $v (qw/path offset limit/) {          foreach my $v (qw/path offset limit/) {
185                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
186          }          }
187    
188          # create Text::Iconv object          if ($arg->{load_row} || $arg->{save_row}) {
189          $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 (
190                            ref($arg->{load_row}) eq 'CODE' &&
191                            ref($arg->{save_row}) eq 'CODE'
192                    );
193                    $self->{load_row} = $arg->{load_row};
194                    $self->{save_row} = $arg->{save_row};
195                    $log->debug("using load_row and save_row instead of in-memory hash");
196            }
197    
198          my $filter_ref;          my $filter_ref;
199          my $recode_regex;          my $recode_regex;
# Line 238  sub open { Line 217  sub open {
217    
218          }          }
219    
220          my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });          my $rec_regex;
221          $log->debug("rec_regex: ", Dumper($rec_regex));          if (my $p = $arg->{modify_file}) {
222                    $log->debug("using modify_file $p");
223          my ($db, $size) = $self->{open_db}->( $self,                  $rec_regex = $self->modify_file_regexps( $p );
224                  path => $arg->{path},          } elsif (my $h = $arg->{modify_records}) {
225                  filter => sub {                  $log->debug("using modify_records ", sub { dump( $h ) });
226                                  my ($l,$f_nr) = @_;                  $rec_regex = $self->modify_record_regexps(%{ $h });
227                                  return unless defined($l);          }
228            $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);  
   
                                 return $l unless ($rec_regex);  
229    
230                                  # apply regexps          my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
                                 if ($rec_regex && defined($rec_regex->{$f_nr})) {  
                                         $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');  
                                         my $c = 0;  
                                         foreach my $r (@{ $rec_regex->{$f_nr} }) {  
                                                 while ( eval '$l =~ ' . $r ) { $c++ };  
                                         }  
                                         warn "## field $f_nr triggered $c regexpes\n" if ($c && $self->{debug});  
                                 }  
231    
232                                  return $l;          my $ll_db = $class->new(
233                  },                  path => $arg->{path},
234                    input_config => $arg->{input_config} || $self->{input_config},
235    #               filter => sub {
236    #                       my ($l,$f_nr) = @_;
237    #                       return unless defined($l);
238    #                       $l = decode($input_encoding, $l);
239    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
240    #                       return $l;
241    #               },
242                  %{ $arg },                  %{ $arg },
243          );          );
244    
245          unless (defined($db)) {          unless (defined($ll_db)) {
246                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
247                  return;                  return;
248          }          }
249    
250            my $size = $ll_db->size;
251    
252          unless ($size) {          unless ($size) {
253                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
254                  return;                  return;
# Line 298  sub open { Line 273  sub open {
273          # store size for later          # store size for later
274          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
275    
276          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');          my $strict_encoding = $arg->{strict_encoding} || $self->{strict_encoding}; ## FIXME should be 1 really
277    
278            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec]",
279                    " encoding $input_encoding ", $strict_encoding ? ' [strict]' : '',
280                    $self->{stats} ? ' [stats]' : '',
281            );
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                  $log->debug(sub { Dumper($rec) });                                  # codepage conversion and recode_regex
299                                    $l = decode($input_encoding, $l, 1);
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 315  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 327  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 361  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 400  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 456  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 494  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 514  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  =head1 modify_record_regexps  =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
624    
625  Generate hash with regexpes to be applied using L<filter>.  Generate hash with regexpes to be applied using L<filter>.
626    
# Line 539  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 567  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  C<low_mem> options is double-edged sword. If enabled, WebPAC  Generate hash with regexpes to be applied using L<filter> from
667  will run on memory constraint machines (which doesn't have enough  pseudo hash/yaml format for regex mappings.
 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.  
668    
669    It should be obvious:
670    
671            200
672              '^a'
673                ' : ' => '^e'
674                ' = ' => '^d'
675    
676    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
677    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
678    
679      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
680    
681    On undef path it will just return.
682    
683    =cut
684    
685    sub modify_file_regexps {
686            my $self = shift;
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    
# Line 604  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 731  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
731    
732  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
733    
734  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
735    
736  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
737  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.597  
changed lines
  Added in v.1107
  ViewVC Help
Powered by ViewVC 1.1.26