/[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 506 by dpavlin, Mon May 15 09:59:05 2006 UTC revision 761 by dpavlin, Wed Oct 25 17:10:08 2006 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;
7    
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
 use Text::Iconv;  
10  use Data::Dumper;  use Data::Dumper;
11    use Encode qw/from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
# Line 14  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.05  Version 0.14
20    
21  =cut  =cut
22    
23  our $VERSION = '0.05';  our $VERSION = '0.14';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 37  C<fetch_rec> and optional C<init> functi Line 39  C<fetch_rec> and optional C<init> functi
39    
40  Perhaps a little code snippet.  Perhaps a little code snippet.
41    
42      use WebPAC::Input;          use WebPAC::Input;
43    
44      my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
45          module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
46                  config => $config,          );
                 lookup => $lookup_obj,  
                 low_mem => 1,  
     );  
47    
48      $db->open('/path/to/database');          $db->open( path => '/path/to/database' );
49          print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
50          while (my $rec = $db->fetch) {          while (my $rec = $db->fetch) {
51                  # do something with $rec                  # do something with $rec
# Line 62  Create new input database object. Line 61  Create new input database object.
61    
62    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
63          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
64          code_page => 'ISO-8859-2',          encoding => 'ISO-8859-2',
         low_mem => 1,  
65          recode => 'char pairs',          recode => 'char pairs',
66          no_progress_bar => 1,          no_progress_bar => 1,
67    );    );
68    
69  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
70  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
71    
72  Optional parametar C<code_page> specify application code page (which will be  Optional parametar C<encoding> specify application code page (which will be
73  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
74  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
75    
 Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  
   
76  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
77  should be replaced in input stream.  should be replaced in input stream.
78    
# Line 94  sub new { Line 90  sub new {
90    
91          my $log = $self->_get_logger;          my $log = $self->_get_logger;
92    
93            $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
94            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
95            $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if ($self->{low_mem});
96    
97          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("specify low-level file format module") unless ($self->{module});
98          my $module = $self->{module};          my $module_path = $self->{module};
99          $module =~ s#::#/#g;          $module_path =~ s#::#/#g;
100          $module .= '.pm';          $module_path .= '.pm';
101          $log->debug("require low-level module $self->{module} from $module");          $log->debug("require low-level module $self->{module} from $module_path");
102    
103          require $module;          require $module_path;
         #eval $self->{module} .'->import';  
104    
105          # check if required subclasses are implemented          # check if required subclasses are implemented
106          foreach my $subclass (qw/open_db fetch_rec init/) {          foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
107                  my $n = $self->{module} . '::' . $subclass;                  # FIXME
                 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, @_);  
108          }          }
109    
110          $self->{'code_page'} ||= 'ISO-8859-2';          $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");  
                 }  
   
                 $self->{'db'} = $db;  
         }  
111    
112          $self ? return $self : return undef;          $self ? return $self : return undef;
113  }  }
# Line 154  sub new { Line 116  sub new {
116    
117  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
118    
119     my $store;     # simple in-memory hash
120    
121   $input->open(   $input->open(
122          path => '/path/to/database/file',          path => '/path/to/database/file',
123          code_page => '852',          code_page => 'cp852',
124          limit => 500,          limit => 500,
125          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
126          stats => 1,          stats => 1,
127            lookup_coderef => sub {
128                    my $rec = shift;
129                    # store lookups
130            },
131            modify_records => {
132                    900 => { '^a' => { ' : ' => '^b' } },
133                    901 => { '*' => { '^b' => ' ; ' } },
134            },
135            modify_file => 'conf/modify/mapping.map',
136            save_row => sub {
137                    my $a = shift;
138                    $store->{ $a->{id} } = $a->{row};
139            },
140            load_row => sub {
141                    my $a = shift;
142                    return defined($store->{ $a->{id} }) &&
143                            $store->{ $a->{id} };
144            },
145    
146   );   );
147    
148  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
149    
150  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.
151    
# Line 171  C<limit> is optional parametar to read j Line 153  C<limit> is optional parametar to read j
153    
154  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
155    
156    C<lookup_coderef> is closure to called to save data into lookups
157    
158    C<modify_records> specify mapping from subfields to delimiters or from
159    delimiters to subfields, as well as oprations on fields (if subfield is
160    defined as C<*>.
161    
162    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
163    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
164    overrides C<modify_records> if both exists for same input.
165    
166    C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
167    is documented in example above.
168    
169  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
170  parametars, see also C<size>.  parametars, see also C<size>.
171    
# Line 182  sub open { Line 177  sub open {
177    
178          my $log = $self->_get_logger();          my $log = $self->_get_logger();
179    
180            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
181            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
182                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
183    
184            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
185    
186          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
187          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
188    
189          # store data in object          # store data in object
190          $self->{'input_code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
# Line 191  sub open { Line 192  sub open {
192                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
193          }          }
194    
195          # create Text::Iconv object          if ($arg->{load_row} || $arg->{save_row}) {
196          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});                  $log->logconfess("save_row and load_row must be defined in pair and be CODE") unless (
197                            ref($arg->{load_row}) eq 'CODE' &&
198                            ref($arg->{save_row}) eq 'CODE'
199                    );
200                    $self->{load_row} = $arg->{load_row};
201                    $self->{save_row} = $arg->{save_row};
202                    $log->debug("using load_row and save_row instead of in-memory hash");
203            }
204    
205          my $filter_ref;          my $filter_ref;
206            my $recode_regex;
207            my $recode_map;
208    
209          if ($self->{recode}) {          if ($self->{recode}) {
210                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
211                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
212                          $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)");
213                  } else {                  } else {
                         my $recode;  
214                          while (@r) {                          while (@r) {
215                                  my $from = shift @r;                                  my $from = shift @r;
216                                  my $to = shift @r;                                  my $to = shift @r;
217                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
218                          }                          }
219    
220                          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;  
                         };  
221    
222                            $log->debug("using recode regex: $recode_regex");
223                  }                  }
224    
225          }          }
226    
227          my ($db, $size) = $self->{open_db}->( $self,          my $rec_regex;
228            if (my $p = $arg->{modify_file}) {
229                    $log->debug("using modify_file $p");
230                    $rec_regex = $self->modify_file_regexps( $p );
231            } elsif (my $h = $arg->{modify_records}) {
232                    $log->debug("using modify_records ", Dumper( $h ));
233                    $rec_regex = $self->modify_record_regexps(%{ $h });
234            }
235            $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
236    
237            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
238    
239            my $ll_db = $class->new(
240                  path => $arg->{path},                  path => $arg->{path},
241                  filter => $filter_ref,  #               filter => sub {
242    #                       my ($l,$f_nr) = @_;
243    #                       return unless defined($l);
244    #                       from_to($l, $code_page, $self->{'encoding'});
245    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
246    #                       return $l;
247    #               },
248                    %{ $arg },
249          );          );
250    
251          unless (defined($db)) {          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 241  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->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
268                  $from_rec = $s;                  $from_rec = $s;
269          } else {          } else {
270                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec;
# Line 256  sub open { Line 279  sub open {
279          # store size for later          # store size for later
280          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
281    
282          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}", $self->{stats} ? ' [stats]' : '');          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
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) = @_;
291    #                               return unless defined($l);
292    #                               return $l unless ($rec_regex && $f_nr);
293    
294                                    $log->debug("-=> $f_nr ## $l");
295    
296                                    # codepage conversion and recode_regex
297                                    from_to($l, $code_page, $self->{'encoding'});
298                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
299    
300                                    # apply regexps
301                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
302                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
303                                            my $c = 0;
304                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
305                                                    my $old_l = $l;
306                                                    eval '$l =~ ' . $r;
307                                                    if ($old_l ne $l) {
308                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
309                                                    }
310                                                    $log->error("error applying regex: $r") if ($@);
311                                            }
312                                    }
313    
314                                    $log->debug("<=- $f_nr ## $l");
315                                    return $l;
316                    });
317    
318                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { Dumper($rec) });
319    
# Line 273  sub open { Line 323  sub open {
323                  }                  }
324    
325                  # store                  # store
326                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
327                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
328                                    id => $pos,
329                                    row => $rec,
330                            });
331                  } else {                  } else {
332                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
333                  }                  }
334    
335                  # create lookup                  # create lookup
336                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
337    
338                  # update counters for statistics                  # update counters for statistics
339                  if ($self->{stats}) {                  if ($self->{stats}) {
340                          map {  
341                                  my $fld = $_;                          # fetch clean record with regexpes applied for statistics
342                            my $rec = $ll_db->fetch_rec($pos);
343    
344                            foreach my $fld (keys %{ $rec }) {
345                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
346                                  if (ref($rec->{ $fld }) eq 'ARRAY') {  
347                                          map {                                  $log->logdie("invalid record fild $fld, not ARRAY")
348                                                  if (ref($_) eq 'HASH') {                                          unless (ref($rec->{ $fld }) eq 'ARRAY');
349                                                          map {          
350                                                                  $self->{_stats}->{sf}->{ $fld }->{ $_ }++;                                  foreach my $row (@{ $rec->{$fld} }) {
351                                                          } keys %{ $_ };  
352                                                  } else {                                          if (ref($row) eq 'HASH') {
353                                                          $self->{_stats}->{repeatable}->{ $fld }++;  
354                                                    foreach my $sf (keys %{ $row }) {
355                                                            next if ($sf eq 'subfields');
356                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
357                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
358                                                                            if (ref($row->{$sf}) eq 'ARRAY');
359                                                  }                                                  }
360                                          } @{ $rec->{$fld} };  
361                                            } else {
362                                                    $self->{_stats}->{repeatable}->{ $fld }++;
363                                            }
364                                  }                                  }
365                          } keys %{ $rec };                          }
366                  }                  }
367    
368                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
# Line 312  sub open { Line 376  sub open {
376          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
377          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
378    
379            # save for dump
380            $self->{ll_db} = $ll_db;
381    
382          return $size;          return $size;
383  }  }
384    
# Line 351  sub fetch { Line 418  sub fetch {
418    
419          my $rec;          my $rec;
420    
421          if ($self->{low_mem}) {          if ($self->{load_row}) {
422                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
423          } else {          } else {
424                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
425          }          }
# Line 426  sub seek { Line 493  sub seek {
493    
494  Dump statistics about field and subfield usage  Dump statistics about field and subfield usage
495    
496    print Dumper( $input->stats );    print $input->stats;
497    
498  =cut  =cut
499    
500  sub stats {  sub stats {
501          my $self = shift;          my $self = shift;
502          return $self->{_stats};  
503            my $log = $self->_get_logger();
504    
505            my $s = $self->{_stats};
506            if (! $s) {
507                    $log->warn("called stats, but there is no statistics collected");
508                    return;
509            }
510    
511            my $max_fld = 0;
512    
513            my $out = join("\n",
514                    map {
515                            my $f = $_ || die "no field";
516                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
517                            $max_fld = $v if ($v > $max_fld);
518    
519                            my $o = sprintf("%4s %d ~", $f, $v);
520    
521                            if (defined($s->{sf}->{$f})) {
522                                    map {
523                                            $o .= sprintf(" %s:%d%s", $_,
524                                                    $s->{sf}->{$f}->{$_}->{count},
525                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
526                                            );
527                                    } sort keys %{ $s->{sf}->{$f} };
528                            }
529    
530                            if (my $v_r = $s->{repeatable}->{$f}) {
531                                    $o .= " ($v_r)" if ($v_r != $v);
532                            }
533    
534                            $o;
535                    } sort { $a cmp $b } keys %{ $s->{fld} }
536            );
537    
538            $log->debug( sub { Dumper($s) } );
539    
540            return $out;
541    }
542    
543    =head2 dump
544    
545    Display humanly readable dump of record
546    
547    =cut
548    
549    sub dump {
550            my $self = shift;
551    
552            return $self->{ll_db}->dump_rec( $self->{pos} );
553    
554    }
555    
556    =head2 modify_record_regexps
557    
558    Generate hash with regexpes to be applied using l<filter>.
559    
560      my $regexpes = $input->modify_record_regexps(
561                    900 => { '^a' => { ' : ' => '^b' } },
562                    901 => { '*' => { '^b' => ' ; ' } },
563      );
564    
565    =cut
566    
567    sub _get_regex {
568            my ($sf,$from,$to) = @_;
569            if ($sf =~ /^\^/) {
570                    return
571                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
572            } else {
573                    return
574                            's/\Q'. $from .'\E/'. $to .'/g';
575            }
576    }
577    
578    sub modify_record_regexps {
579            my $self = shift;
580            my $modify_record = {@_};
581    
582            my $regexpes;
583    
584            my $log = $self->_get_logger();
585    
586            foreach my $f (keys %$modify_record) {
587                    $log->debug("field: $f");
588    
589                    foreach my $sf (keys %{ $modify_record->{$f} }) {
590                            $log->debug("subfield: $sf");
591    
592                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
593                                    my $to = $modify_record->{$f}->{$sf}->{$from};
594                                    #die "no field?" unless defined($to);
595                                    $log->debug("transform: |$from| -> |$to|");
596    
597                                    my $regex = _get_regex($sf,$from,$to);
598                                    push @{ $regexpes->{$f} }, $regex;
599                                    $log->debug("regex: $regex");
600                            }
601                    }
602            }
603    
604            return $regexpes;
605  }  }
606    
607  =head1 MEMORY USAGE  =head2 modify_file_regexps
608    
609    Generate hash with regexpes to be applied using l<filter> from
610    pseudo hash/yaml format for regex mappings.
611    
612  C<low_mem> options is double-edged sword. If enabled, WebPAC  It should be obvious:
 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.  
613    
614            200
615              '^a'
616                ' : ' => '^e'
617                ' = ' => '^d'
618    
619    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
620    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
621    
622      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
623    
624    On undef path it will just return.
625    
626    =cut
627    
628    sub modify_file_regexps {
629            my $self = shift;
630    
631            my $modify_path = shift || return;
632    
633            my $log = $self->_get_logger();
634    
635            my $regexpes;
636    
637            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
638    
639            my ($f,$sf);
640    
641            while(<$fh>) {
642                    chomp;
643                    next if (/^#/ || /^\s*$/);
644    
645                    if (/^\s*(\d+)\s*$/) {
646                            $f = $1;
647                            $log->debug("field: $f");
648                            next;
649                    } elsif (/^\s*'([^']*)'\s*$/) {
650                            $sf = $1;
651                            $log->die("can't define subfiled before field in: $_") unless ($f);
652                            $log->debug("subfield: $sf");
653                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
654                            my ($from,$to) = ($1, $2);
655    
656                            $log->debug("transform: |$from| -> |$to|");
657    
658                            my $regex = _get_regex($sf,$from,$to);
659                            push @{ $regexpes->{$f} }, $regex;
660                            $log->debug("regex: $regex");
661                    }
662            }
663    
664            return $regexpes;
665    }
666    
667  =head1 AUTHOR  =head1 AUTHOR
668    
# Line 472  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 670  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
670    
671  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
672    
673  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
674    
675  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
676  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.506  
changed lines
  Added in v.761
  ViewVC Help
Powered by ViewVC 1.1.26