/[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 513 by dpavlin, Tue May 16 13:08:31 2006 UTC revision 1286 by dpavlin, Fri Sep 18 21:30:30 2009 UTC
# Line 3  package WebPAC::Input; Line 3  package WebPAC::Input;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6  use blib;  use lib 'lib';
7    
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Text::Iconv;  use Data::Dump qw/dump/;
11  use Data::Dumper;  use Encode qw/decode from_to/;
12    use YAML;
13    
14  =head1 NAME  =head1 NAME
15    
16  WebPAC::Input - read different file formats into WebPAC  WebPAC::Input - read different file formats into WebPAC
17    
 =head1 VERSION  
   
 Version 0.05  
   
18  =cut  =cut
19    
20  our $VERSION = '0.05';  our $VERSION = '0.19';
21    
22  =head1 SYNOPSIS  =head1 SYNOPSIS
23    
# Line 39  C<fetch_rec> and optional C<init> functi Line 36  C<fetch_rec> and optional C<init> functi
36    
37  Perhaps a little code snippet.  Perhaps a little code snippet.
38    
39      use WebPAC::Input;          use WebPAC::Input;
40    
41      my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
42          module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
43                  config => $config,          );
                 lookup => $lookup_obj,  
                 low_mem => 1,  
     );  
44    
45      $db->open('/path/to/database');          $db->open( path => '/path/to/database' );
46          print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
47          while (my $rec = $db->fetch) {          while (my $rec = $db->fetch) {
48                  # do something with $rec                  # do something with $rec
# Line 64  Create new input database object. Line 58  Create new input database object.
58    
59    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
60          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
         code_page => 'ISO-8859-2',  
         low_mem => 1,  
61          recode => 'char pairs',          recode => 'char pairs',
62          no_progress_bar => 1,          no_progress_bar => 1,
63            input_config => {
64                    mapping => [ 'foo', 'bar', 'baz' ],
65            },
66    );    );
67    
68  C<module> is low-level file format module. See L<WebPAC::Input::Isis> and  C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
69  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
70    
 Optional parametar C<code_page> specify application code page (which will be  
 used internally). This should probably be your terminal encoding, and by  
 default, it C<ISO-8859-2>.  
   
 Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  
   
71  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
72  should be replaced in input stream.  should be replaced in input stream.
73    
# Line 96  sub new { Line 85  sub new {
85    
86          my $log = $self->_get_logger;          my $log = $self->_get_logger;
87    
88          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
89          my $module = $self->{module};          $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
90          $module =~ s#::#/#g;          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if $self->{lookup};
91          $module .= '.pm';          $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if $self->{low_mem};
         $log->debug("require low-level module $self->{module} from $module");  
   
         require $module;  
         #eval $self->{module} .'->import';  
   
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init/) {  
                 my $n = $self->{module} . '::' . $subclass;  
                 if (! defined &{ $n }) {  
                         my $missing = "missing $subclass in $self->{module}";  
                         $self->{$subclass} = sub { $log->logwarn($missing) };  
                 } else {  
                         $self->{$subclass} = \&{ $n };  
                 }  
         }  
   
         if ($self->{init}) {  
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
         }  
   
         $self->{'code_page'} ||= 'ISO-8859-2';  
   
         # running with low_mem flag? well, use DBM::Deep then.  
         if ($self->{'low_mem'}) {  
                 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");  
   
                 my $db_file = "data.db";  
   
                 if (-e $db_file) {  
                         unlink $db_file or $log->logdie("can't remove '$db_file' from last run");  
                         $log->debug("removed '$db_file' from last run");  
                 }  
92    
93                  require DBM::Deep;          $log->logconfess("specify low-level file format module") unless ($self->{module});
94            my $module_path = $self->{module};
95                  my $db = new DBM::Deep $db_file;          $module_path =~ s#::#/#g;
96            $module_path .= '.pm';
97                  $log->logdie("DBM::Deep error: $!") unless ($db);          $log->debug("require low-level module $self->{module} from $module_path");
   
                 if ($db->error()) {  
                         $log->logdie("can't open '$db_file' under low_mem: ",$db->error());  
                 } else {  
                         $log->debug("using file '$db_file' for DBM::Deep");  
                 }  
98    
99                  $self->{'db'} = $db;          require $module_path;
         }  
100    
101          $self ? return $self : return undef;          $self ? return $self : return undef;
102  }  }
# Line 156  sub new { Line 105  sub new {
105    
106  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
107    
108     my $store;     # simple in-memory hash
109    
110   $input->open(   $input->open(
111          path => '/path/to/database/file',          path => '/path/to/database/file',
112          code_page => '852',          input_encoding => 'cp852',
113            strict_encoding => 0,
114          limit => 500,          limit => 500,
115          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
116          stats => 1,          stats => 1,
117            lookup_coderef => sub {
118                    my $rec = shift;
119                    # store lookups
120            },
121            modify_records => {
122                    900 => { '^a' => { ' : ' => '^b' } },
123                    901 => { '*' => { '^b' => ' ; ' } },
124            },
125            modify_file => 'conf/modify/mapping.map',
126            save_row => sub {
127                    my $a = shift;
128                    $store->{ $a->{id} } = $a->{row};
129            },
130            load_row => sub {
131                    my $a = shift;
132                    return defined($store->{ $a->{id} }) &&
133                            $store->{ $a->{id} };
134            },
135    
136   );   );
137    
138  By default, C<code_page> is assumed to be C<852>.  By default, C<input_encoding> is assumed to be C<cp852>.
139    
140  C<offset> is optional parametar to position at some offset before reading from database.  C<offset> is optional parametar to position at some offset before reading from database.
141    
# Line 173  C<limit> is optional parametar to read j Line 143  C<limit> is optional parametar to read j
143    
144  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
145    
146    C<lookup_coderef> is closure to called to save data into lookups
147    
148    C<modify_records> specify mapping from subfields to delimiters or from
149    delimiters to subfields, as well as oprations on fields (if subfield is
150    defined as C<*>.
151    
152    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
153    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
154    overrides C<modify_records> if both exists for same input.
155    
156    C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
157    is documented in example above.
158    
159    C<strict_encoding> should really default to 1, but it doesn't for now.
160    
161  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
162  parametars, see also C<size>.  parametars, see also C<size>.
163    
# Line 183  sub open { Line 168  sub open {
168          my $arg = {@_};          my $arg = {@_};
169    
170          my $log = $self->_get_logger();          my $log = $self->_get_logger();
171            $log->debug( "arguments: ",dump( $arg ));
172    
173            $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
174            $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
175            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
176            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
177                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
178    
179            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
180    
181          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
182          my $code_page = $arg->{'code_page'} || '852';          my $input_encoding = $arg->{'input_encoding'} || $self->{'input_encoding'} || 'cp852';
183    
184          # store data in object          # store data in object
         $self->{'input_code_page'} = $code_page;  
185          foreach my $v (qw/path offset limit/) {          foreach my $v (qw/path offset limit/) {
186                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if defined $arg->{$v};
187          }          }
188    
189          # create Text::Iconv object          if ($arg->{load_row} || $arg->{save_row}) {
190          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});                  $log->logconfess("save_row and load_row must be defined in pair and be CODE") unless (
191                            ref($arg->{load_row}) eq 'CODE' &&
192                            ref($arg->{save_row}) eq 'CODE'
193                    );
194                    $self->{load_row} = $arg->{load_row};
195                    $self->{save_row} = $arg->{save_row};
196                    $log->debug("using load_row and save_row instead of in-memory hash");
197            }
198    
199          my $filter_ref;          my $filter_ref;
200            my $recode_regex;
201            my $recode_map;
202    
203          if ($self->{recode}) {          if ($self->{recode}) {
204                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
205                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
206                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");
207                  } else {                  } else {
                         my $recode;  
208                          while (@r) {                          while (@r) {
209                                  my $from = shift @r;                                  my $from = shift @r;
210                                  my $to = shift @r;                                  my $to = shift @r;
211                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
212                          }                          }
213    
214                          my $regex = join '|' => keys %{ $recode };                          $recode_regex = join '|' => keys %{ $recode_map };
   
                         $log->debug("using recode regex: $regex");  
                           
                         $filter_ref = sub {  
                                 my $t = shift;  
                                 $t =~ s/($regex)/$recode->{$1}/g;  
                                 return $t;  
                         };  
215    
216                            $log->debug("using recode regex: $recode_regex");
217                  }                  }
218    
219          }          }
220    
221          my ($db, $size) = $self->{open_db}->( $self,          my $rec_regex;
222            if (my $p = $arg->{modify_file}) {
223                    $log->debug("using modify_file $p");
224                    $rec_regex = $self->modify_file_regexps( $p );
225            } elsif (my $h = $arg->{modify_records}) {
226                    $log->debug("using modify_records ", sub { dump( $h ) });
227                    $rec_regex = $self->modify_record_regexps(%{ $h });
228            }
229            $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
230    
231            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
232    
233            $arg->{$_} = $self->{$_} foreach qw(offset limit);
234    
235            my $ll_db = $class->new(
236                  path => $arg->{path},                  path => $arg->{path},
237                  filter => $filter_ref,                  input_config => $arg->{input_config} || $self->{input_config},
238    #               filter => sub {
239    #                       my ($l,$f_nr) = @_;
240    #                       return unless defined($l);
241    #                       $l = decode($input_encoding, $l);
242    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
243    #                       return $l;
244    #               },
245                    %{ $arg },
246          );          );
247    
248          unless (defined($db)) {          # save for dump and input_module
249            $self->{ll_db} = $ll_db;
250    
251            unless (defined($ll_db)) {
252                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
253                  return;                  return;
254          }          }
255    
256            my $size = $ll_db->size;
257    
258          unless ($size) {          unless ($size) {
259                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
260                  return;                  return;
# Line 258  sub open { Line 279  sub open {
279          # store size for later          # store size for later
280          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
281    
282          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}", $self->{stats} ? ' [stats]' : '');          my $strict_encoding = $arg->{strict_encoding} || $self->{strict_encoding}; ## FIXME should be 1 really
283    
284            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec]",
285                    " encoding $input_encoding ", $strict_encoding ? ' [strict]' : '',
286                    $self->{stats} ? ' [stats]' : '',
287            );
288    
289          # read database          # read database
290          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
291    
292                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
293    
294                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
295                                    my ($l,$f_nr,$debug) = @_;
296    #                               return unless defined($l);
297    #                               return $l unless ($rec_regex && $f_nr);
298    
299                                    return unless ( defined($l) && defined($f_nr) );
300    
301                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
302                                    $log->debug("-=> $f_nr ## $l");
303    
304                                    # codepage conversion and recode_regex
305                                    $l = decode($input_encoding, $l, 1);
306                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
307    
308                                    # apply regexps
309                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
310                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
311                                            my $c = 0;
312                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
313                                                    my $old_l = $l;
314                                                    $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
315                                                    eval '$l =~ ' . $r->{regex};
316                                                    if ($old_l ne $l) {
317                                                            my $d = "|$old_l| -> |$l| "; # . $r->{regex};
318                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
319                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
320                                                            $log->debug("MODIFY $d");
321                                                            warn "*** $d\n" if ($debug);
322    
323                                                    }
324                                                    $log->error("error applying regex: ",dump($r), $@) if $@;
325                                            }
326                                    }
327    
328                                    $log->debug("<=- $f_nr ## |$l|");
329                                    warn "<=- $f_nr ## $l\n" if ($debug);
330                                    return $l;
331                    });
332    
333                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
334    
335                  if (! $rec) {                  if (! $rec) {
336                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 275  sub open { Line 338  sub open {
338                  }                  }
339    
340                  # store                  # store
341                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
342                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
343                                    id => $pos,
344                                    row => $rec,
345                            });
346                  } else {                  } else {
347                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
348                  }                  }
349    
350                  # create lookup                  # create lookup
351                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
352    
353                  # update counters for statistics                  # update counters for statistics
354                  if ($self->{stats}) {                  if ($self->{stats}) {
355                          map {  
356                                  my $fld = $_;                          # fetch clean record with regexpes applied for statistics
357                            my $rec = $ll_db->fetch_rec($pos);
358    
359                            foreach my $fld (keys %{ $rec }) {
360                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
361                                  if (ref($rec->{ $fld }) eq 'ARRAY') {  
362                                          map {                                  #$log->logdie("invalid record fild $fld, not ARRAY")
363                                                  if (ref($_) eq 'HASH') {                                  next unless (ref($rec->{ $fld }) eq 'ARRAY');
364                                                          map {          
365                                                                  $self->{_stats}->{sf}->{ $fld }->{ $_ }++;                                  foreach my $row (@{ $rec->{$fld} }) {
366                                                          } keys %{ $_ };  
367                                                  } else {                                          if (ref($row) eq 'HASH') {
368                                                          $self->{_stats}->{repeatable}->{ $fld }++;  
369                                                    foreach my $sf (keys %{ $row }) {
370                                                            next if ($sf eq 'subfields');
371                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
372                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
373                                                                            if (ref($row->{$sf}) eq 'ARRAY');
374                                                  }                                                  }
375                                          } @{ $rec->{$fld} };  
376                                            } else {
377                                                    $self->{_stats}->{repeatable}->{ $fld }++;
378                                            }
379                                  }                                  }
380                          } keys %{ $rec };                          }
381                  }                  }
382    
383                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
# Line 317  sub open { Line 394  sub open {
394          return $size;          return $size;
395  }  }
396    
397    sub input_module { $_[0]->{ll_db} }
398    
399  =head2 fetch  =head2 fetch
400    
401  Fetch next record from database. It will also displays progress bar.  Fetch next record from database. It will also displays progress bar.
# Line 353  sub fetch { Line 432  sub fetch {
432    
433          my $rec;          my $rec;
434    
435          if ($self->{low_mem}) {          if ($self->{load_row}) {
436                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
437          } else {          } else {
438                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
439          }          }
# Line 409  First record in database has position 1. Line 488  First record in database has position 1.
488    
489  sub seek {  sub seek {
490          my $self = shift;          my $self = shift;
491          my $pos = shift || return;          my $pos = shift;
492    
493          my $log = $self->_get_logger();          my $log = $self->_get_logger();
494    
495            $log->logconfess("called without pos") unless defined($pos);
496    
497          if ($pos < 1) {          if ($pos < 1) {
498                  $log->warn("seek before first record");                  $log->warn("seek before first record");
499                  $pos = 1;                  $pos = 1;
# Line 447  sub stats { Line 528  sub stats {
528    
529          my $out = join("\n",          my $out = join("\n",
530                  map {                  map {
531                          my $f = $_ || die "no field";                          my $f = $_;
532                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
533                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
534                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
535    
536                          my $o = sprintf("%4d %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
537    
538                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
539                                    my @subfields = keys %{ $s->{sf}->{$f} };
540                                  map {                                  map {
541                                          $o .= sprintf(" %s:%d", $_, $s->{sf}->{$f}->{$_});                                          $o .= sprintf(" %s:%d%s", $_,
542                                  } sort keys %{ $s->{sf}->{$f} };                                                  $s->{sf}->{$f}->{$_}->{count},
543                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
544                                            );
545                                    } (
546                                            # first indicators and other special subfields
547                                            sort( grep { length($_)  > 1 } @subfields ),
548                                            # then subfileds (single char)
549                                            sort( grep { length($_) == 1 } @subfields ),
550                                    );
551                          }                          }
552    
553                          if (my $v_r = $s->{repeatable}->{$f}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 464  sub stats { Line 555  sub stats {
555                          }                          }
556    
557                          $o;                          $o;
558                  } sort { $a <=> $b } keys %{ $s->{fld} }                  } sort {
559                            if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
560                                    $a <=> $b
561                            } else {
562                                    $a cmp $b
563                            }
564                    } keys %{ $s->{fld} }
565          );          );
566    
567          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
568    
569            my $path = 'var/stats.yml';
570            YAML::DumpFile( $path, $s );
571            $log->info( 'created ', $path, ' with ', -s $path, ' bytes' );
572    
573          return $out;          return $out;
574  }  }
575    
576  =head1 MEMORY USAGE  =head2 dump_ascii
577    
578    Display humanly readable dump of record
579    
580    =cut
581    
582    sub dump_ascii {
583            my $self = shift;
584    
585            return unless $self->{ll_db};
586    
587            if ($self->{ll_db}->can('dump_ascii')) {
588                    return $self->{ll_db}->dump_ascii( $self->{pos} );
589            } else {
590                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
591            }
592    }
593    
594    =head2 _get_regex
595    
596    Helper function called which create regexps to be execute on code.
597    
598      _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
599      _get_regex( 900, '^b', ' : ^b' );
600    
601    It supports perl regexps with C<regex:> prefix to from value and has
602    additional logic to skip empty subfields.
603    
604    =cut
605    
606    sub _get_regex {
607            my ($sf,$from,$to) = @_;
608    
609            # protect /
610            $from =~ s!/!\\/!gs;
611            $to =~ s!/!\\/!gs;
612    
613            if ($from =~ m/^regex:(.+)$/) {
614                    $from = $1;
615            } else {
616                    $from = '\Q' . $from . '\E';
617            }
618            if ($sf =~ /^\^/) {
619                    my $need_subfield_data = '*';   # no
620                    # if from is also subfield, require some data in between
621                    # to correctly skip empty subfields
622                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
623                    return
624                            's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
625            } else {
626                    return
627                            's/'. $from .'/'. $to .'/g';
628            }
629    }
630    
631    
632    =head2 modify_record_regexps
633    
634    Generate hash with regexpes to be applied using L<filter>.
635    
636      my $regexpes = $input->modify_record_regexps(
637                    900 => { '^a' => { ' : ' => '^b' } },
638                    901 => { '*' => { '^b' => ' ; ' } },
639      );
640    
641    =cut
642    
643    sub modify_record_regexps {
644            my $self = shift;
645            my $modify_record = {@_};
646    
647            my $regexpes;
648    
649            my $log = $self->_get_logger();
650    
651            foreach my $f (keys %$modify_record) {
652                    $log->debug("field: $f");
653    
654                    foreach my $sf (keys %{ $modify_record->{$f} }) {
655                            $log->debug("subfield: $sf");
656    
657                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
658                                    my $to = $modify_record->{$f}->{$sf}->{$from};
659                                    #die "no field?" unless defined($to);
660                                    my $d = "|$from| -> |$to|";
661                                    $log->debug("transform: $d");
662    
663                                    my $regex = _get_regex($sf,$from,$to);
664                                    push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
665                                    $log->debug("regex: $regex");
666                            }
667                    }
668            }
669    
670            return $regexpes;
671    }
672    
673    =head2 modify_file_regexps
674    
675  C<low_mem> options is double-edged sword. If enabled, WebPAC  Generate hash with regexpes to be applied using L<filter> from
676  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.  
677    
678    It should be obvious:
679    
680            200
681              '^a'
682                ' : ' => '^e'
683                ' = ' => '^d'
684    
685    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
686    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
687    
688      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
689    
690    On undef path it will just return.
691    
692    =cut
693    
694    sub modify_file_regexps {
695            my $self = shift;
696    
697            my $modify_path = shift || return;
698    
699            my $log = $self->_get_logger();
700    
701            my $regexpes;
702    
703            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
704    
705            my ($f,$sf);
706    
707            while(<$fh>) {
708                    chomp;
709                    next if (/^#/ || /^\s*$/);
710    
711                    if (/^\s*(\d+)\s*$/) {
712                            $f = $1;
713                            $log->debug("field: $f");
714                            next;
715                    } elsif (/^\s*'([^']*)'\s*$/) {
716                            $sf = $1;
717                            $log->die("can't define subfiled before field in: $_") unless ($f);
718                            $log->debug("subfield: $sf");
719                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
720                            my ($from,$to) = ($1, $2);
721    
722                            $log->debug("transform: |$from| -> |$to|");
723    
724                            my $regex = _get_regex($sf,$from,$to);
725                            push @{ $regexpes->{$f} }, {
726                                    regex => $regex,
727                                    file => $modify_path,
728                                    line => $.,
729                            };
730                            $log->debug("regex: $regex");
731                    } else {
732                            die "can't parse: $_";
733                    }
734            }
735    
736            return $regexpes;
737    }
738    
739  =head1 AUTHOR  =head1 AUTHOR
740    
# Line 509  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 742  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
742    
743  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
744    
745  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
746    
747  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
748  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.513  
changed lines
  Added in v.1286
  ViewVC Help
Powered by ViewVC 1.1.26