/[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 1306 by dpavlin, Mon Sep 21 15:48:52 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.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");  
                 }  
98    
99                  require DBM::Deep;          require $module_path;
   
                 my $db = new DBM::Deep $db_file;  
   
                 $log->logdie("DBM::Deep error: $!") unless ($db);  
   
                 if ($db->error()) {  
                         $log->logdie("can't open '$db_file' under low_mem: ",$db->error());  
                 } else {  
                         $log->debug("using file '$db_file' for DBM::Deep");  
                 }  
   
                 $self->{'db'} = $db;  
         }  
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 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 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 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->{'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            $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 },                  %{ $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 257  sub open { Line 264  sub open {
264          my $to_rec = $size;          my $to_rec = $size;
265    
266          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
267                  $log->debug("skipping to MFN $s");                  $log->debug("offset $s records");
268                  $from_rec = $s;                  $from_rec = $s + 1;
269          } else {          } else {
270                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec - 1;
271          }          }
272    
273          if ($self->{limit}) {          if ($self->{limit}) {
# Line 270  sub open { Line 277  sub open {
277          }          }
278    
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 + 1;
281    
282          $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
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 289  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                  }                  }
# Line 301  sub open { Line 353  sub open {
353                  # update counters for statistics                  # update counters for statistics
354                  if ($self->{stats}) {                  if ($self->{stats}) {
355    
356                            # fetch clean record with regexpes applied for statistics
357                            my $rec = $ll_db->fetch_rec($pos);
358    
359                          foreach my $fld (keys %{ $rec }) {                          foreach my $fld (keys %{ $rec }) {
360                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
361    
362                                  $log->logdie("invalid record fild $fld, not ARRAY")                                  #$log->logdie("invalid record fild $fld, not ARRAY")
363                                          unless (ref($rec->{ $fld }) eq 'ARRAY');                                  next unless (ref($rec->{ $fld }) eq 'ARRAY');
364                    
365                                  foreach my $row (@{ $rec->{$fld} }) {                                  foreach my $row (@{ $rec->{$fld} }) {
366    
367                                          if (ref($row) eq 'HASH') {                                          if (ref($row) eq 'HASH') {
368    
369                                                  foreach my $sf (keys %{ $row }) {                                                  foreach my $sf (keys %{ $row }) {
370                                                            next if ($sf eq 'subfields');
371                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
372                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++                                                          $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
373                                                                          if (ref($row->{$sf}) eq 'ARRAY');                                                                          if (ref($row->{$sf}) eq 'ARRAY');
# Line 338  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 357  sub fetch { Line 415  sub fetch {
415          $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});
416    
417          if ($self->{pos} == -1) {          if ($self->{pos} == -1) {
418                  $self->{pos} = $self->{offset};                  $self->{pos} = $self->{offset} + 1;
419          } else {          } else {
420                  $self->{pos}++;                  $self->{pos}++;
421          }          }
# Line 374  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 415  because it takes into account C<offset> Line 473  because it takes into account C<offset>
473    
474  sub size {  sub size {
475          my $self = shift;          my $self = shift;
476          return $self->{size};          $self->{ll_db}->size if $self->{ll_db}->can('size');
477            return $self->{size}; # FIXME this is buggy if open is called multiple times!
478  }  }
479    
480  =head2 seek  =head2 seek
# Line 430  First record in database has position 1. Line 489  First record in database has position 1.
489    
490  sub seek {  sub seek {
491          my $self = shift;          my $self = shift;
492          my $pos = shift || return;          my $pos = shift;
493    
494          my $log = $self->_get_logger();          my $log = $self->_get_logger();
495    
496            $log->logconfess("called without pos") unless defined($pos);
497    
498          if ($pos < 1) {          if ($pos < 1) {
499                  $log->warn("seek before first record");                  $log->warn("seek before first record");
500                  $pos = 1;                  $pos = 1;
# Line 468  sub stats { Line 529  sub stats {
529    
530          my $out = join("\n",          my $out = join("\n",
531                  map {                  map {
532                          my $f = $_ || die "no field";                          my $f = $_;
533                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
534                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
535                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
536    
537                          my $o = sprintf("%4s %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
538    
539                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
540                                    my @subfields = keys %{ $s->{sf}->{$f} };
541                                  map {                                  map {
542                                          $o .= sprintf(" %s:%d%s", $_,                                          $o .= sprintf(" %s:%d%s", $_,
543                                                  $s->{sf}->{$f}->{$_}->{count},                                                  $s->{sf}->{$f}->{$_}->{count},
544                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',                                                  $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
545                                          );                                          );
546                                  } sort keys %{ $s->{sf}->{$f} };                                  } (
547                                            # first indicators and other special subfields
548                                            sort( grep { length($_)  > 1 } @subfields ),
549                                            # then subfileds (single char)
550                                            sort( grep { length($_) == 1 } @subfields ),
551                                    );
552                          }                          }
553    
554                          if (my $v_r = $s->{repeatable}->{$f}) {                          if (my $v_r = $s->{repeatable}->{$f}) {
# Line 488  sub stats { Line 556  sub stats {
556                          }                          }
557    
558                          $o;                          $o;
559                  } sort { $a cmp $b } keys %{ $s->{fld} }                  } sort {
560                            if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
561                                    $a <=> $b
562                            } else {
563                                    $a cmp $b
564                            }
565                    } keys %{ $s->{fld} }
566          );          );
567    
568          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
569    
570            my $path = 'var/stats.yml';
571            YAML::DumpFile( $path, $s );
572            $log->info( 'created ', $path, ' with ', -s $path, ' bytes' );
573    
574          return $out;          return $out;
575  }  }
576    
577  =head1 MEMORY USAGE  =head2 dump_ascii
578    
579    Display humanly readable dump of record
580    
581    =cut
582    
583    sub dump_ascii {
584            my $self = shift;
585    
586            return unless $self->{ll_db};
587    
588            if ($self->{ll_db}->can('dump_ascii')) {
589                    return $self->{ll_db}->dump_ascii( $self->{pos} );
590            } else {
591                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
592            }
593    }
594    
595    =head2 _get_regex
596    
597    Helper function called which create regexps to be execute on code.
598    
599      _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
600      _get_regex( 900, '^b', ' : ^b' );
601    
602    It supports perl regexps with C<regex:> prefix to from value and has
603    additional logic to skip empty subfields.
604    
605    =cut
606    
607    sub _get_regex {
608            my ($sf,$from,$to) = @_;
609    
610  C<low_mem> options is double-edged sword. If enabled, WebPAC          # protect /
611  will run on memory constraint machines (which doesn't have enough          $from =~ s!/!\\/!gs;
612  physical RAM to create memory structure for whole source database).          $to =~ s!/!\\/!gs;
613    
614  If your machine has 512Mb or more of RAM and database is around 10000 records,          if ($from =~ m/^regex:(.+)$/) {
615  memory shouldn't be an issue. If you don't have enough physical RAM, you                  $from = $1;
616  might consider using virtual memory (if your operating system is handling it          } else {
617  well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle                  $from = '\Q' . $from . '\E';
618  parsed structure of ISIS database (this is what C<low_mem> option does).          }
619            if ($sf =~ /^\^/) {
620  Hitting swap at end of reading source database is probably o.k. However,                  my $need_subfield_data = '*';   # no
621  hitting swap before 90% will dramatically decrease performance and you will                  # if from is also subfield, require some data in between
622  be better off with C<low_mem> and using rest of availble memory for                  # to correctly skip empty subfields
623  operating system disk cache (Linux is particuallary good about this).                  $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
624  However, every access to database record will require disk access, so                  return
625  generation phase will be slower 10-100 times.                          's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
626            } else {
627  Parsed structures are essential - you just have option to trade RAM memory                  return
628  (which is fast) for disk space (which is slow). Be sure to have planty of                          's/'. $from .'/'. $to .'/g';
629  disk space if you are using C<low_mem> and thus L<DBM::Deep>.          }
630    }
 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.  
631    
632    
633    =head2 modify_record_regexps
634    
635    Generate hash with regexpes to be applied using L<filter>.
636    
637      my $regexpes = $input->modify_record_regexps(
638                    900 => { '^a' => { ' : ' => '^b' } },
639                    901 => { '*' => { '^b' => ' ; ' } },
640      );
641    
642    =cut
643    
644    sub modify_record_regexps {
645            my $self = shift;
646            my $modify_record = {@_};
647    
648            my $regexpes;
649    
650            my $log = $self->_get_logger();
651    
652            foreach my $f (keys %$modify_record) {
653                    $log->debug("field: $f");
654    
655                    foreach my $sf (keys %{ $modify_record->{$f} }) {
656                            $log->debug("subfield: $sf");
657    
658                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
659                                    my $to = $modify_record->{$f}->{$sf}->{$from};
660                                    #die "no field?" unless defined($to);
661                                    my $d = "|$from| -> |$to|";
662                                    $log->debug("transform: $d");
663    
664                                    my $regex = _get_regex($sf,$from,$to);
665                                    push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
666                                    $log->debug("regex: $regex");
667                            }
668                    }
669            }
670    
671            return $regexpes;
672    }
673    
674    =head2 modify_file_regexps
675    
676    Generate hash with regexpes to be applied using L<filter> from
677    pseudo hash/yaml format for regex mappings.
678    
679    It should be obvious:
680    
681            200
682              '^a'
683                ' : ' => '^e'
684                ' = ' => '^d'
685    
686    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
687    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
688    
689      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
690    
691    On undef path it will just return.
692    
693    =cut
694    
695    sub modify_file_regexps {
696            my $self = shift;
697    
698            my $modify_path = shift || return;
699    
700            my $log = $self->_get_logger();
701    
702            my $regexpes;
703    
704            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
705    
706            my ($f,$sf);
707    
708            while(<$fh>) {
709                    chomp;
710                    next if (/^#/ || /^\s*$/);
711    
712                    if (/^\s*(\d+)\s*$/) {
713                            $f = $1;
714                            $log->debug("field: $f");
715                            next;
716                    } elsif (/^\s*'([^']*)'\s*$/) {
717                            $sf = $1;
718                            $log->die("can't define subfiled before field in: $_") unless ($f);
719                            $log->debug("subfield: $sf");
720                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
721                            my ($from,$to) = ($1, $2);
722    
723                            $log->debug("transform: |$from| -> |$to|");
724    
725                            my $regex = _get_regex($sf,$from,$to);
726                            push @{ $regexpes->{$f} }, {
727                                    regex => $regex,
728                                    file => $modify_path,
729                                    line => $.,
730                            };
731                            $log->debug("regex: $regex");
732                    } else {
733                            die "can't parse: $_";
734                    }
735            }
736    
737            return $regexpes;
738    }
739    
740  =head1 AUTHOR  =head1 AUTHOR
741    
742  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
743    
744  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
745    
746  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
747    
748  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
749  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.593  
changed lines
  Added in v.1306
  ViewVC Help
Powered by ViewVC 1.1.26