/[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 593 by dpavlin, Sun Jul 9 15:22:39 2006 UTC revision 1128 by dpavlin, Tue Apr 21 21:03:52 2009 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    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.08  
   
18  =cut  =cut
19    
20  our $VERSION = '0.08';  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,          );
                 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 63  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',
         encoding => '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<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).  
   
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 95  sub new { Line 85  sub new {
85    
86          my $log = $self->_get_logger;          my $log = $self->_get_logger;
87    
88          $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};
89          $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};
90            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if $self->{lookup};
91            $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if $self->{low_mem};
92    
93          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
94          my $module = $self->{module};          my $module_path = $self->{module};
95          $module =~ s#::#/#g;          $module_path =~ s#::#/#g;
96          $module .= '.pm';          $module_path .= '.pm';
97          $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;  
   
                 my $db = new DBM::Deep $db_file;  
   
                 $log->logdie("DBM::Deep error: $!") unless ($db);  
98    
99                  if ($db->error()) {          require $module_path;
                         $log->logdie("can't open '$db_file' under low_mem: ",$db->error());  
                 } else {  
                         $log->debug("using file '$db_file' for DBM::Deep");  
                 }  
   
                 $self->{'db'} = $db;  
         }  
100    
101          $self ? return $self : return undef;          $self ? return $self : return undef;
102  }  }
# Line 158  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_ref => sub {          lookup_coderef => sub {
118                  my ($k,$v) = @_;                  my $rec = shift;
119                  # store lookup $k => $v                  # 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 179  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 call when adding key => $value combinations to  C<lookup_coderef> is closure to called to save data into lookups
147  lookup.  
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>.
# Line 192  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});          $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}))          $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
177                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');                  if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
178    
179            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
180    
181          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
182          my $code_page = $arg->{'code_page'} || '852';          my $input_encoding = $arg->{'input_encoding'} || $self->{'input_encoding'} || 'cp852';
183    
184          # store data in object          # store data in object
         $self->{'input_code_page'} = $code_page;  
185          foreach my $v (qw/path offset limit/) {          foreach my $v (qw/path offset limit/) {
186                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
187          }          }
188    
189          # create Text::Iconv object          if ($arg->{load_row} || $arg->{save_row}) {
190          $self->{iconv} = Text::Iconv->new($code_page,$self->{'encoding'});      ## FIXME remove!                  $log->logconfess("save_row and load_row must be defined in pair and be CODE") unless (
191                            ref($arg->{load_row}) eq 'CODE' &&
192                            ref($arg->{save_row}) eq 'CODE'
193                    );
194                    $self->{load_row} = $arg->{load_row};
195                    $self->{save_row} = $arg->{save_row};
196                    $log->debug("using load_row and save_row instead of in-memory hash");
197            }
198    
199          my $filter_ref;          my $filter_ref;
200            my $recode_regex;
201            my $recode_map;
202    
203          if ($self->{recode}) {          if ($self->{recode}) {
204                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
205                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
206                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");
207                  } else {                  } else {
                         my $recode;  
208                          while (@r) {                          while (@r) {
209                                  my $from = shift @r;                                  my $from = shift @r;
210                                  my $to = shift @r;                                  my $to = shift @r;
211                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
212                          }                          }
213    
214                          my $regex = join '|' => keys %{ $recode };                          $recode_regex = join '|' => keys %{ $recode_map };
   
                         $log->debug("using recode regex: $regex");  
                           
                         $filter_ref = sub {  
                                 my $t = shift;  
                                 $t =~ s/($regex)/$recode->{$1}/g;  
                                 return $t;  
                         };  
215    
216                            $log->debug("using recode regex: $recode_regex");
217                  }                  }
218    
219          }          }
220    
221          my ($db, $size) = $self->{open_db}->( $self,          my $rec_regex;
222            if (my $p = $arg->{modify_file}) {
223                    $log->debug("using modify_file $p");
224                    $rec_regex = $self->modify_file_regexps( $p );
225            } elsif (my $h = $arg->{modify_records}) {
226                    $log->debug("using modify_records ", sub { dump( $h ) });
227                    $rec_regex = $self->modify_record_regexps(%{ $h });
228            }
229            $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
230    
231            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
232    
233            my $ll_db = $class->new(
234                  path => $arg->{path},                  path => $arg->{path},
235                  filter => $filter_ref,                  input_config => $arg->{input_config} || $self->{input_config},
236    #               filter => sub {
237    #                       my ($l,$f_nr) = @_;
238    #                       return unless defined($l);
239    #                       $l = decode($input_encoding, $l);
240    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
241    #                       return $l;
242    #               },
243                  %{ $arg },                  %{ $arg },
244          );          );
245    
246          unless (defined($db)) {          unless (defined($ll_db)) {
247                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
248                  return;                  return;
249          }          }
250    
251            my $size = $ll_db->size;
252    
253          unless ($size) {          unless ($size) {
254                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
255                  return;                  return;
# Line 272  sub open { Line 274  sub open {
274          # store size for later          # store size for later
275          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
276    
277          $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
278    
279            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec]",
280                    " encoding $input_encoding ", $strict_encoding ? ' [strict]' : '',
281                    $self->{stats} ? ' [stats]' : '',
282            );
283    
284          # read database          # read database
285          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
286    
287                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
288    
289                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
290                                    my ($l,$f_nr,$debug) = @_;
291    #                               return unless defined($l);
292    #                               return $l unless ($rec_regex && $f_nr);
293    
294                                    return unless ( defined($l) && defined($f_nr) );
295    
296                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
297                                    $log->debug("-=> $f_nr ## $l");
298    
299                                    # codepage conversion and recode_regex
300                                    $l = decode($input_encoding, $l, 1);
301                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
302    
303                                    # apply regexps
304                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
305                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
306                                            my $c = 0;
307                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
308                                                    my $old_l = $l;
309                                                    $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
310                                                    eval '$l =~ ' . $r->{regex};
311                                                    if ($old_l ne $l) {
312                                                            my $d = "|$old_l| -> |$l| "; # . $r->{regex};
313                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
314                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
315                                                            $log->debug("MODIFY $d");
316                                                            warn "*** $d\n" if ($debug);
317    
318                                                    }
319                                                    $log->error("error applying regex: ",dump($r), $@) if $@;
320                                            }
321                                    }
322    
323                                    $log->debug("<=- $f_nr ## |$l|");
324                                    warn "<=- $f_nr ## $l\n" if ($debug);
325                                    return $l;
326                    });
327    
328                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
329    
330                  if (! $rec) {                  if (! $rec) {
331                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 289  sub open { Line 333  sub open {
333                  }                  }
334    
335                  # store                  # store
336                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
337                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
338                                    id => $pos,
339                                    row => $rec,
340                            });
341                  } else {                  } else {
342                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
343                  }                  }
# Line 301  sub open { Line 348  sub open {
348                  # update counters for statistics                  # update counters for statistics
349                  if ($self->{stats}) {                  if ($self->{stats}) {
350    
351                            # fetch clean record with regexpes applied for statistics
352                            my $rec = $ll_db->fetch_rec($pos);
353    
354                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
355                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
356    
357                                  $log->logdie("invalid record fild $fld, not ARRAY")                                  #$log->logdie("invalid record fild $fld, not ARRAY")
358                                          unless (ref($rec->{ $fld }) eq 'ARRAY');                                  next unless (ref($rec->{ $fld }) eq 'ARRAY');
359                    
360                                  foreach my $row (@{ $rec->{$fld} }) {                                  foreach my $row (@{ $rec->{$fld} }) {
361    
362                                          if (ref($row) eq 'HASH') {                                          if (ref($row) eq 'HASH') {
363    
364                                                  foreach my $sf (keys %{ $row }) {                                                  foreach my $sf (keys %{ $row }) {
365                                                            next if ($sf eq 'subfields');
366                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
367                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
368                                                                          if (ref($row->{$sf}) eq 'ARRAY');                                                                          if (ref($row->{$sf}) eq 'ARRAY');
# Line 335  sub open { Line 386  sub open {
386          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
387          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
388    
389            # save for dump
390            $self->{ll_db} = $ll_db;
391    
392          return $size;          return $size;
393  }  }
394    
# Line 374  sub fetch { Line 428  sub fetch {
428    
429          my $rec;          my $rec;
430    
431          if ($self->{low_mem}) {          if ($self->{load_row}) {
432                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
433          } else {          } else {
434                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
435          }          }
# Line 430  First record in database has position 1. Line 484  First record in database has position 1.
484    
485  sub seek {  sub seek {
486          my $self = shift;          my $self = shift;
487          my $pos = shift || return;          my $pos = shift;
488    
489          my $log = $self->_get_logger();          my $log = $self->_get_logger();
490    
491            $log->logconfess("called without pos") unless defined($pos);
492    
493          if ($pos < 1) {          if ($pos < 1) {
494                  $log->warn("seek before first record");                  $log->warn("seek before first record");
495                  $pos = 1;                  $pos = 1;
# Line 468  sub stats { Line 524  sub stats {
524    
525          my $out = join("\n",          my $out = join("\n",
526                  map {                  map {
527                          my $f = $_ || die "no field";                          my $f = $_;
528                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
529                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
530                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
531    
532                          my $o = sprintf("%4s %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
533    
534                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
535                                    my @subfields = keys %{ $s->{sf}->{$f} };
536                                  map {                                  map {
537                                          $o .= sprintf(" %s:%d%s", $_,                                          $o .= sprintf(" %s:%d%s", $_,
538                                                  $s->{sf}->{$f}->{$_}->{count},                                                  $s->{sf}->{$f}->{$_}->{count},
539                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
540                                          );                                          );
541                                  } sort keys %{ $s->{sf}->{$f} };                                  } (
542                                            # first indicators and other special subfields
543                                            sort( grep { length($_)  > 1 } @subfields ),
544                                            # then subfileds (single char)
545                                            sort( grep { length($_) == 1 } @subfields ),
546                                    );
547                          }                          }
548    
549                          if (my $v_r = $s->{repeatable}->{$f}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 488  sub stats { Line 551  sub stats {
551                          }                          }
552    
553                          $o;                          $o;
554                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort {
555                            if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
556                                    $a <=> $b
557                            } else {
558                                    $a cmp $b
559                            }
560                    } keys %{ $s->{fld} }
561          );          );
562    
563          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
564    
565            my $path = 'var/stats.yml';
566            YAML::DumpFile( $path, $s );
567            $log->info( 'created ', $path, ' with ', -s $path, ' bytes' );
568    
569          return $out;          return $out;
570  }  }
571    
572  =head1 MEMORY USAGE  =head2 dump_ascii
573    
574    Display humanly readable dump of record
575    
576    =cut
577    
578    sub dump_ascii {
579            my $self = shift;
580    
581            return unless $self->{ll_db};
582    
583            if ($self->{ll_db}->can('dump_ascii')) {
584                    return $self->{ll_db}->dump_ascii( $self->{pos} );
585            } else {
586                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
587            }
588    }
589    
590    =head2 _get_regex
591    
592    Helper function called which create regexps to be execute on code.
593    
594      _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
595      _get_regex( 900, '^b', ' : ^b' );
596    
597    It supports perl regexps with C<regex:> prefix to from value and has
598    additional logic to skip empty subfields.
599    
600    =cut
601    
602    sub _get_regex {
603            my ($sf,$from,$to) = @_;
604    
605            # protect /
606            $from =~ s!/!\\/!gs;
607            $to =~ s!/!\\/!gs;
608    
609            if ($from =~ m/^regex:(.+)$/) {
610                    $from = $1;
611            } else {
612                    $from = '\Q' . $from . '\E';
613            }
614            if ($sf =~ /^\^/) {
615                    my $need_subfield_data = '*';   # no
616                    # if from is also subfield, require some data in between
617                    # to correctly skip empty subfields
618                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
619                    return
620                            's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
621            } else {
622                    return
623                            's/'. $from .'/'. $to .'/g';
624            }
625    }
626    
627    
628    =head2 modify_record_regexps
629    
630    Generate hash with regexpes to be applied using L<filter>.
631    
632      my $regexpes = $input->modify_record_regexps(
633                    900 => { '^a' => { ' : ' => '^b' } },
634                    901 => { '*' => { '^b' => ' ; ' } },
635      );
636    
637    =cut
638    
639    sub modify_record_regexps {
640            my $self = shift;
641            my $modify_record = {@_};
642    
643            my $regexpes;
644    
645            my $log = $self->_get_logger();
646    
647            foreach my $f (keys %$modify_record) {
648                    $log->debug("field: $f");
649    
650                    foreach my $sf (keys %{ $modify_record->{$f} }) {
651                            $log->debug("subfield: $sf");
652    
653                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
654                                    my $to = $modify_record->{$f}->{$sf}->{$from};
655                                    #die "no field?" unless defined($to);
656                                    my $d = "|$from| -> |$to|";
657                                    $log->debug("transform: $d");
658    
659                                    my $regex = _get_regex($sf,$from,$to);
660                                    push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
661                                    $log->debug("regex: $regex");
662                            }
663                    }
664            }
665    
666            return $regexpes;
667    }
668    
669    =head2 modify_file_regexps
670    
671    Generate hash with regexpes to be applied using L<filter> from
672    pseudo hash/yaml format for regex mappings.
673    
674    It should be obvious:
675    
676            200
677              '^a'
678                ' : ' => '^e'
679                ' = ' => '^d'
680    
681    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
682    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
683    
684      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
685    
686    On undef path it will just return.
687    
688    =cut
689    
690    sub modify_file_regexps {
691            my $self = shift;
692    
693            my $modify_path = shift || return;
694    
695            my $log = $self->_get_logger();
696    
697            my $regexpes;
698    
699            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
700    
701            my ($f,$sf);
702    
703  C<low_mem> options is double-edged sword. If enabled, WebPAC          while(<$fh>) {
704  will run on memory constraint machines (which doesn't have enough                  chomp;
705  physical RAM to create memory structure for whole source database).                  next if (/^#/ || /^\s*$/);
   
 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.  
706    
707                    if (/^\s*(\d+)\s*$/) {
708                            $f = $1;
709                            $log->debug("field: $f");
710                            next;
711                    } elsif (/^\s*'([^']*)'\s*$/) {
712                            $sf = $1;
713                            $log->die("can't define subfiled before field in: $_") unless ($f);
714                            $log->debug("subfield: $sf");
715                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
716                            my ($from,$to) = ($1, $2);
717    
718                            $log->debug("transform: |$from| -> |$to|");
719    
720                            my $regex = _get_regex($sf,$from,$to);
721                            push @{ $regexpes->{$f} }, {
722                                    regex => $regex,
723                                    file => $modify_path,
724                                    line => $.,
725                            };
726                            $log->debug("regex: $regex");
727                    } else {
728                            die "can't parse: $_";
729                    }
730            }
731    
732            return $regexpes;
733    }
734    
735  =head1 AUTHOR  =head1 AUTHOR
736    
# Line 533  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 738  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
738    
739  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
740    
741  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
742    
743  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
744  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.593  
changed lines
  Added in v.1128
  ViewVC Help
Powered by ViewVC 1.1.26