/[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 619 by dpavlin, Fri Aug 25 12:31:06 2006 UTC revision 1307 by dpavlin, Mon Sep 21 16:42:25 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.11  
   
18  =cut  =cut
19    
20  our $VERSION = '0.11';  our $VERSION = '0.19';
21    
22  =head1 SYNOPSIS  =head1 SYNOPSIS
23    
# Line 43  Perhaps a little code snippet. Line 40  Perhaps a little code snippet.
40    
41          my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
42                  module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
                 low_mem => 1,  
43          );          );
44    
45          $db->open( path => '/path/to/database' );          $db->open( path => '/path/to/database' );
# Line 62  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 94  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);  
   
                 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 157  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 => {          modify_records => {
122                  900 => { '^a' => { ' : ' => '^b' } },                  900 => { '^a' => { ' : ' => '^b' } },
123                  901 => { '*' => { '^b' => ' ; ' } },                  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 skip records at beginning.
141    
142  C<limit> is optional parametar to read just C<limit> records from database  C<limit> is optional parametar to read just C<limit> records from database
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 C<< key => 'value' >> combinations to  C<lookup_coderef> is closure to called to save data into lookups
 lookup.  
147    
148  C<modify_records> specify mapping from subfields to delimiters or from  C<modify_records> specify mapping from subfields to delimiters or from
149  delimiters to subfields, as well as oprations on fields (if subfield is  delimiters to subfields, as well as oprations on fields (if subfield is
150  defined as C<*>.  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 199  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
185          $self->{'input_code_page'} = $code_page;          $self->{$_} = $arg->{$_} foreach grep { defined $arg->{$_} } qw(path offset limit);
         foreach my $v (qw/path offset limit/) {  
                 $self->{$v} = $arg->{$v} if ($arg->{$v});  
         }  
186    
187          # create Text::Iconv object          if ($arg->{load_row} || $arg->{save_row}) {
188          $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 (
189                            ref($arg->{load_row}) eq 'CODE' &&
190                            ref($arg->{save_row}) eq 'CODE'
191                    );
192                    $self->{load_row} = $arg->{load_row};
193                    $self->{save_row} = $arg->{save_row};
194                    $log->debug("using load_row and save_row instead of in-memory hash");
195            }
196    
197          my $filter_ref;          my $filter_ref;
198          my $recode_regex;          my $recode_regex;
# Line 238  sub open { Line 216  sub open {
216    
217          }          }
218    
219          my $rec_regex = $self->modify_record_regexps(%{ $arg->{modify_records} });          my $rec_regex;
220          $log->debug("rec_regex: ", Dumper($rec_regex));          if (my $p = $arg->{modify_file}) {
221                    $log->debug("using modify_file $p");
222          my ($db, $size) = $self->{open_db}->( $self,                  $rec_regex = $self->modify_file_regexps( $p );
223                  path => $arg->{path},          } elsif (my $h = $arg->{modify_records}) {
224                  filter => sub {                  $log->debug("using modify_records ", sub { dump( $h ) });
225                                  my ($l,$f_nr) = @_;                  $rec_regex = $self->modify_record_regexps(%{ $h });
226                                  return unless defined($l);          }
227            $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
228    
229                                  ## FIXME remove iconv!          my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
                                 $l = $self->{iconv}->convert($l) if ($self->{iconv});  
           
                                 $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);  
230    
231                                  ## FIXME remove this warning when we are sure that none of API is calling          $arg->{$_} = $self->{$_} foreach qw(offset limit);
                                 ## this wrongly  
                                 warn "filter called without field number" unless ($f_nr);  
232    
233                                  return $l;          my $ll_db = $class->new(
234                  },                  path => $arg->{path},
235                    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)) {          # save for dump and input_module
247            $self->{ll_db} = $ll_db;
248    
249            unless (defined($ll_db)) {
250                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
251                  return;                  return;
252          }          }
253    
254            my $size = $ll_db->size;
255    
256          unless ($size) {          unless ($size) {
257                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
258                  return;                  return;
# Line 275  sub open { Line 262  sub open {
262          my $to_rec = $size;          my $to_rec = $size;
263    
264          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
265                  $log->debug("skipping to MFN $s");                  $log->debug("offset $s records");
266                  $from_rec = $s;                  $from_rec = $s + 1;
267          } else {          } else {
268                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec - 1;
269          }          }
270    
271          if ($self->{limit}) {          if ($self->{limit}) {
# Line 287  sub open { Line 274  sub open {
274                  $to_rec = $size if ($to_rec > $size);                  $to_rec = $size if ($to_rec > $size);
275          }          }
276    
277          # store size for later          my $strict_encoding = $arg->{strict_encoding} || $self->{strict_encoding}; ## FIXME should be 1 really
         $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;  
278    
279          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');          $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            $self->{size} = 0;
285    
286          # read database          # read database
287          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
288    
289                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
290    
291                  my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {                  $self->{size}++; # XXX I could move this more down if I didn't want empty records...
292                                  my ($l,$f_nr) = @_;  
293                                  return unless defined($l);                  my $rec = $ll_db->fetch_rec($pos, sub {
294                                  return $l unless ($rec_regex && $f_nr);                                  my ($l,$f_nr,$debug) = @_;
295    #                               return unless defined($l);
296    #                               return $l unless ($rec_regex && $f_nr);
297    
298                                    return unless ( defined($l) && defined($f_nr) );
299    
300                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
301                                    $log->debug("-=> $f_nr ## $l");
302    
303                                    # codepage conversion and recode_regex
304                                    $l = decode($input_encoding, $l, 1);
305                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
306    
307                                  # apply regexps                                  # apply regexps
308                                  if ($rec_regex && defined($rec_regex->{$f_nr})) {                                  if ($rec_regex && defined($rec_regex->{$f_nr})) {
309                                          $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');                                          $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
310                                          my $c = 0;                                          my $c = 0;
311                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {                                          foreach my $r (@{ $rec_regex->{$f_nr} }) {
312                                                  #$log->debug("\$l = $l\neval \$l =~ $r");                                                  my $old_l = $l;
313                                                  eval '$l =~ ' . $r;                                                  $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
314                                                  $log->error("error applying regex: $r") if ($@);                                                  eval '$l =~ ' . $r->{regex};
315                                                    if ($old_l ne $l) {
316                                                            my $d = "|$old_l| -> |$l| "; # . $r->{regex};
317                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
318                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
319                                                            $log->debug("MODIFY $d");
320                                                            warn "*** $d\n" if ($debug);
321    
322                                                    }
323                                                    $log->error("error applying regex: ",dump($r), $@) if $@;
324                                          }                                          }
325                                  }                                  }
326    
327                                    $log->debug("<=- $f_nr ## |$l|");
328                                    warn "<=- $f_nr ## $l\n" if ($debug);
329                                  return $l;                                  return $l;
330                  });                  });
331    
332                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
333    
334                  if (! $rec) {                  if (! $rec) {
335                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 324  sub open { Line 337  sub open {
337                  }                  }
338    
339                  # store                  # store
340                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
341                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
342                                    id => $pos,
343                                    row => $rec,
344                            });
345                  } else {                  } else {
346                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
347                  }                  }
# Line 337  sub open { Line 353  sub open {
353                  if ($self->{stats}) {                  if ($self->{stats}) {
354    
355                          # fetch clean record with regexpes applied for statistics                          # fetch clean record with regexpes applied for statistics
356                          my $rec = $self->{fetch_rec}->($self, $db, $pos);                          my $rec = $ll_db->fetch_rec($pos);
357    
358                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
359                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
360    
361                                  $log->logdie("invalid record fild $fld, not ARRAY")                                  #$log->logdie("invalid record fild $fld, not ARRAY")
362                                          unless (ref($rec->{ $fld }) eq 'ARRAY');                                  next unless (ref($rec->{ $fld }) eq 'ARRAY');
363                    
364                                  foreach my $row (@{ $rec->{$fld} }) {                                  foreach my $row (@{ $rec->{$fld} }) {
365    
# Line 377  sub open { Line 393  sub open {
393          return $size;          return $size;
394  }  }
395    
396    sub input_module { $_[0]->{ll_db} }
397    
398  =head2 fetch  =head2 fetch
399    
400  Fetch next record from database. It will also displays progress bar.  Fetch next record from database. It will also displays progress bar.
# Line 396  sub fetch { Line 414  sub fetch {
414          $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});          $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
415    
416          if ($self->{pos} == -1) {          if ($self->{pos} == -1) {
417                  $self->{pos} = $self->{offset};                  $self->{pos} = $self->{offset} + 1;
418          } else {          } else {
419                  $self->{pos}++;                  $self->{pos}++;
420          }          }
# Line 413  sub fetch { Line 431  sub fetch {
431    
432          my $rec;          my $rec;
433    
434          if ($self->{low_mem}) {          if ($self->{load_row}) {
435                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
436          } else {          } else {
437                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
438          }          }
# Line 454  because it takes into account C<offset> Line 472  because it takes into account C<offset>
472    
473  sub size {  sub size {
474          my $self = shift;          my $self = shift;
475          return $self->{size};          return $self->{size}; # FIXME this is buggy if open is called multiple times!
476  }  }
477    
478  =head2 seek  =head2 seek
# Line 469  First record in database has position 1. Line 487  First record in database has position 1.
487    
488  sub seek {  sub seek {
489          my $self = shift;          my $self = shift;
490          my $pos = shift || return;          my $pos = shift;
491    
492          my $log = $self->_get_logger();          my $log = $self->_get_logger();
493    
494            $log->logconfess("called without pos") unless defined($pos);
495    
496          if ($pos < 1) {          if ($pos < 1) {
497                  $log->warn("seek before first record");                  $log->warn("seek before first record");
498                  $pos = 1;                  $pos = 1;
# Line 507  sub stats { Line 527  sub stats {
527    
528          my $out = join("\n",          my $out = join("\n",
529                  map {                  map {
530                          my $f = $_ || die "no field";                          my $f = $_;
531                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
532                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
533                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
534    
535                          my $o = sprintf("%4s %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
536    
537                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
538                                    my @subfields = keys %{ $s->{sf}->{$f} };
539                                  map {                                  map {
540                                          $o .= sprintf(" %s:%d%s", $_,                                          $o .= sprintf(" %s:%d%s", $_,
541                                                  $s->{sf}->{$f}->{$_}->{count},                                                  $s->{sf}->{$f}->{$_}->{count},
542                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
543                                          );                                          );
544                                  } sort keys %{ $s->{sf}->{$f} };                                  } (
545                                            # first indicators and other special subfields
546                                            sort( grep { length($_)  > 1 } @subfields ),
547                                            # then subfileds (single char)
548                                            sort( grep { length($_) == 1 } @subfields ),
549                                    );
550                          }                          }
551    
552                          if (my $v_r = $s->{repeatable}->{$f}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 527  sub stats { Line 554  sub stats {
554                          }                          }
555    
556                          $o;                          $o;
557                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort {
558                            if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
559                                    $a <=> $b
560                            } else {
561                                    $a cmp $b
562                            }
563                    } keys %{ $s->{fld} }
564          );          );
565    
566          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
567    
568            my $path = 'var/stats.yml';
569            YAML::DumpFile( $path, $s );
570            $log->info( 'created ', $path, ' with ', -s $path, ' bytes' );
571    
572          return $out;          return $out;
573  }  }
574    
575    =head2 dump_ascii
576    
577    Display humanly readable dump of record
578    
579    =cut
580    
581    sub dump_ascii {
582            my $self = shift;
583    
584            return unless $self->{ll_db};
585    
586            if ($self->{ll_db}->can('dump_ascii')) {
587                    return $self->{ll_db}->dump_ascii( $self->{pos} );
588            } else {
589                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
590            }
591    }
592    
593    =head2 _get_regex
594    
595    Helper function called which create regexps to be execute on code.
596    
597      _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
598      _get_regex( 900, '^b', ' : ^b' );
599    
600    It supports perl regexps with C<regex:> prefix to from value and has
601    additional logic to skip empty subfields.
602    
603    =cut
604    
605    sub _get_regex {
606            my ($sf,$from,$to) = @_;
607    
608            # protect /
609            $from =~ s!/!\\/!gs;
610            $to =~ s!/!\\/!gs;
611    
612            if ($from =~ m/^regex:(.+)$/) {
613                    $from = $1;
614            } else {
615                    $from = '\Q' . $from . '\E';
616            }
617            if ($sf =~ /^\^/) {
618                    my $need_subfield_data = '*';   # no
619                    # if from is also subfield, require some data in between
620                    # to correctly skip empty subfields
621                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
622                    return
623                            's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
624            } else {
625                    return
626                            's/'. $from .'/'. $to .'/g';
627            }
628    }
629    
630    
631  =head2 modify_record_regexps  =head2 modify_record_regexps
632    
633  Generate hash with regexpes to be applied using L<filter>.  Generate hash with regexpes to be applied using L<filter>.
# Line 552  sub modify_record_regexps { Line 645  sub modify_record_regexps {
645    
646          my $regexpes;          my $regexpes;
647    
648            my $log = $self->_get_logger();
649    
650          foreach my $f (keys %$modify_record) {          foreach my $f (keys %$modify_record) {
651  warn "--- f: $f\n";                  $log->debug("field: $f");
652    
653                  foreach my $sf (keys %{ $modify_record->{$f} }) {                  foreach my $sf (keys %{ $modify_record->{$f} }) {
654  warn "---- sf: $sf\n";                          $log->debug("subfield: $sf");
655    
656                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {                          foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
657                                  my $to = $modify_record->{$f}->{$sf}->{$from};                                  my $to = $modify_record->{$f}->{$sf}->{$from};
658                                  #die "no field?" unless defined($to);                                  #die "no field?" unless defined($to);
659  warn "----- transform: |$from| -> |$to|\n";                                  my $d = "|$from| -> |$to|";
660                                    $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";  
                                 }  
661    
662                                    my $regex = _get_regex($sf,$from,$to);
663                                    push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
664                                    $log->debug("regex: $regex");
665                          }                          }
666                  }                  }
667          }          }
# Line 580  warn ">>>>> $regex [global]\n"; Line 669  warn ">>>>> $regex [global]\n";
669          return $regexpes;          return $regexpes;
670  }  }
671    
672  =head1 MEMORY USAGE  =head2 modify_file_regexps
673    
674    Generate hash with regexpes to be applied using L<filter> from
675    pseudo hash/yaml format for regex mappings.
676    
677    It should be obvious:
678    
679            200
680              '^a'
681                ' : ' => '^e'
682                ' = ' => '^d'
683    
684    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
685    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
686    
687  C<low_mem> options is double-edged sword. If enabled, WebPAC    my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
 will run on memory constraint machines (which doesn't have enough  
 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.  
688    
689    On undef path it will just return.
690    
691    =cut
692    
693    sub modify_file_regexps {
694            my $self = shift;
695    
696            my $modify_path = shift || return;
697    
698            my $log = $self->_get_logger();
699    
700            my $regexpes;
701    
702            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
703    
704            my ($f,$sf);
705    
706            while(<$fh>) {
707                    chomp;
708                    next if (/^#/ || /^\s*$/);
709    
710                    if (/^\s*(\d+)\s*$/) {
711                            $f = $1;
712                            $log->debug("field: $f");
713                            next;
714                    } elsif (/^\s*'([^']*)'\s*$/) {
715                            $sf = $1;
716                            $log->die("can't define subfiled before field in: $_") unless ($f);
717                            $log->debug("subfield: $sf");
718                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
719                            my ($from,$to) = ($1, $2);
720    
721                            $log->debug("transform: |$from| -> |$to|");
722    
723                            my $regex = _get_regex($sf,$from,$to);
724                            push @{ $regexpes->{$f} }, {
725                                    regex => $regex,
726                                    file => $modify_path,
727                                    line => $.,
728                            };
729                            $log->debug("regex: $regex");
730                    } else {
731                            die "can't parse: $_";
732                    }
733            }
734    
735            return $regexpes;
736    }
737    
738  =head1 AUTHOR  =head1 AUTHOR
739    
Legend:
Removed from v.619  
changed lines
  Added in v.1307
  ViewVC Help
Powered by ViewVC 1.1.26