/[webpac2]/trunk/lib/WebPAC/Input.pm
This is repository of my old source code which isn't updated any more. Go to git.rot13.org for current projects!
ViewVC logotype

Diff of /trunk/lib/WebPAC/Input.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 513 by dpavlin, Tue May 16 13:08:31 2006 UTC revision 797 by dpavlin, Sun Feb 4 13:28:30 2007 UTC
# Line 7  use blib; Line 7  use blib;
7    
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Text::Iconv;  use Data::Dump qw/dump/;
11  use Data::Dumper;  use Encode qw/from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
# Line 16  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.17
20    
21  =cut  =cut
22    
23  our $VERSION = '0.05';  our $VERSION = '0.17';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 39  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 64  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 96  sub new { Line 90  sub new {
90    
91          my $log = $self->_get_logger;          my $log = $self->_get_logger;
92    
93          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
94          my $module = $self->{module};          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
95          $module =~ s#::#/#g;          $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if ($self->{low_mem});
         $module .= '.pm';  
         $log->debug("require low-level module $self->{module} from $module");  
   
         require $module;  
         #eval $self->{module} .'->import';  
   
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init/) {  
                 my $n = $self->{module} . '::' . $subclass;  
                 if (! defined &{ $n }) {  
                         my $missing = "missing $subclass in $self->{module}";  
                         $self->{$subclass} = sub { $log->logwarn($missing) };  
                 } else {  
                         $self->{$subclass} = \&{ $n };  
                 }  
         }  
   
         if ($self->{init}) {  
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
         }  
   
         $self->{'code_page'} ||= 'ISO-8859-2';  
   
         # running with low_mem flag? well, use DBM::Deep then.  
         if ($self->{'low_mem'}) {  
                 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");  
   
                 my $db_file = "data.db";  
   
                 if (-e $db_file) {  
                         unlink $db_file or $log->logdie("can't remove '$db_file' from last run");  
                         $log->debug("removed '$db_file' from last run");  
                 }  
   
                 require DBM::Deep;  
96    
97                  my $db = new DBM::Deep $db_file;          $log->logconfess("specify low-level file format module") unless ($self->{module});
98            my $module_path = $self->{module};
99            $module_path =~ s#::#/#g;
100            $module_path .= '.pm';
101            $log->debug("require low-level module $self->{module} from $module_path");
102    
103                  $log->logdie("DBM::Deep error: $!") unless ($db);          require $module_path;
104    
105                  if ($db->error()) {          $self->{'encoding'} ||= 'ISO-8859-2';
                         $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;  
         }  
106    
107          $self ? return $self : return undef;          $self ? return $self : return undef;
108  }  }
# Line 156  sub new { Line 111  sub new {
111    
112  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
113    
114     my $store;     # simple in-memory hash
115    
116   $input->open(   $input->open(
117          path => '/path/to/database/file',          path => '/path/to/database/file',
118          code_page => '852',          code_page => 'cp852',
119          limit => 500,          limit => 500,
120          offset => 6000,          offset => 6000,
         lookup => $lookup_obj,  
121          stats => 1,          stats => 1,
122            lookup_coderef => sub {
123                    my $rec = shift;
124                    # store lookups
125            },
126            modify_records => {
127                    900 => { '^a' => { ' : ' => '^b' } },
128                    901 => { '*' => { '^b' => ' ; ' } },
129            },
130            modify_file => 'conf/modify/mapping.map',
131            save_row => sub {
132                    my $a = shift;
133                    $store->{ $a->{id} } = $a->{row};
134            },
135            load_row => sub {
136                    my $a = shift;
137                    return defined($store->{ $a->{id} }) &&
138                            $store->{ $a->{id} };
139            },
140    
141   );   );
142    
143  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
144    
145  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.
146    
# Line 173  C<limit> is optional parametar to read j Line 148  C<limit> is optional parametar to read j
148    
149  C<stats> create optional report about usage of fields and subfields  C<stats> create optional report about usage of fields and subfields
150    
151    C<lookup_coderef> is closure to called to save data into lookups
152    
153    C<modify_records> specify mapping from subfields to delimiters or from
154    delimiters to subfields, as well as oprations on fields (if subfield is
155    defined as C<*>.
156    
157    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
158    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
159    overrides C<modify_records> if both exists for same input.
160    
161    C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
162    is documented in example above.
163    
164  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
165  parametars, see also C<size>.  parametars, see also C<size>.
166    
# Line 184  sub open { Line 172  sub open {
172    
173          my $log = $self->_get_logger();          my $log = $self->_get_logger();
174    
175            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
176            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
177                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
178    
179            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
180    
181          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
182          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
183    
184          # store data in object          # store data in object
185          $self->{'input_code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
# Line 193  sub open { Line 187  sub open {
187                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
188          }          }
189    
190          # create Text::Iconv object          if ($arg->{load_row} || $arg->{save_row}) {
191          $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 (
192                            ref($arg->{load_row}) eq 'CODE' &&
193                            ref($arg->{save_row}) eq 'CODE'
194                    );
195                    $self->{load_row} = $arg->{load_row};
196                    $self->{save_row} = $arg->{save_row};
197                    $log->debug("using load_row and save_row instead of in-memory hash");
198            }
199    
200          my $filter_ref;          my $filter_ref;
201            my $recode_regex;
202            my $recode_map;
203    
204          if ($self->{recode}) {          if ($self->{recode}) {
205                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
206                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
207                          $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)");
208                  } else {                  } else {
                         my $recode;  
209                          while (@r) {                          while (@r) {
210                                  my $from = shift @r;                                  my $from = shift @r;
211                                  my $to = shift @r;                                  my $to = shift @r;
212                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
213                          }                          }
214    
215                          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;  
                         };  
216    
217                            $log->debug("using recode regex: $recode_regex");
218                  }                  }
219    
220          }          }
221    
222          my ($db, $size) = $self->{open_db}->( $self,          my $rec_regex;
223            if (my $p = $arg->{modify_file}) {
224                    $log->debug("using modify_file $p");
225                    $rec_regex = $self->modify_file_regexps( $p );
226            } elsif (my $h = $arg->{modify_records}) {
227                    $log->debug("using modify_records ", sub { dump( $h ) });
228                    $rec_regex = $self->modify_record_regexps(%{ $h });
229            }
230            $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
231    
232            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
233    
234            my $ll_db = $class->new(
235                  path => $arg->{path},                  path => $arg->{path},
236                  filter => $filter_ref,  #               filter => sub {
237    #                       my ($l,$f_nr) = @_;
238    #                       return unless defined($l);
239    #                       from_to($l, $code_page, $self->{'encoding'});
240    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
241    #                       return $l;
242    #               },
243                    %{ $arg },
244          );          );
245    
246          unless (defined($db)) {          unless (defined($ll_db)) {
247                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
248                  return;                  return;
249          }          }
250    
251            my $size = $ll_db->size;
252    
253          unless ($size) {          unless ($size) {
254                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
255                  return;                  return;
# Line 258  sub open { Line 274  sub open {
274          # store size for later          # store size for later
275          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
276    
277          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}", $self->{stats} ? ' [stats]' : '');          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
278    
279          # read database          # read database
280          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
281    
282                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
283    
284                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
285                                    my ($l,$f_nr) = @_;
286    #                               return unless defined($l);
287    #                               return $l unless ($rec_regex && $f_nr);
288    
289                                    $log->debug("-=> $f_nr ## $l");
290    
291                                    # codepage conversion and recode_regex
292                                    from_to($l, $code_page, $self->{'encoding'});
293                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
294    
295                                    # apply regexps
296                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
297                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
298                                            my $c = 0;
299                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
300                                                    my $old_l = $l;
301                                                    eval '$l =~ ' . $r;
302                                                    if ($old_l ne $l) {
303                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
304                                                    }
305                                                    $log->error("error applying regex: $r") if ($@);
306                                            }
307                                    }
308    
309                                    $log->debug("<=- $f_nr ## $l");
310                                    return $l;
311                    });
312    
313                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
314    
315                  if (! $rec) {                  if (! $rec) {
316                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 275  sub open { Line 318  sub open {
318                  }                  }
319    
320                  # store                  # store
321                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
322                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
323                                    id => $pos,
324                                    row => $rec,
325                            });
326                  } else {                  } else {
327                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
328                  }                  }
329    
330                  # create lookup                  # create lookup
331                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
332    
333                  # update counters for statistics                  # update counters for statistics
334                  if ($self->{stats}) {                  if ($self->{stats}) {
335                          map {  
336                                  my $fld = $_;                          # fetch clean record with regexpes applied for statistics
337                            my $rec = $ll_db->fetch_rec($pos);
338    
339                            foreach my $fld (keys %{ $rec }) {
340                                  $self->{_stats}->{fld}->{ $fld }++;                                  $self->{_stats}->{fld}->{ $fld }++;
341                                  if (ref($rec->{ $fld }) eq 'ARRAY') {  
342                                          map {                                  $log->logdie("invalid record fild $fld, not ARRAY")
343                                                  if (ref($_) eq 'HASH') {                                          unless (ref($rec->{ $fld }) eq 'ARRAY');
344                                                          map {          
345                                                                  $self->{_stats}->{sf}->{ $fld }->{ $_ }++;                                  foreach my $row (@{ $rec->{$fld} }) {
346                                                          } keys %{ $_ };  
347                                                  } else {                                          if (ref($row) eq 'HASH') {
348                                                          $self->{_stats}->{repeatable}->{ $fld }++;  
349                                                    foreach my $sf (keys %{ $row }) {
350                                                            next if ($sf eq 'subfields');
351                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
352                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
353                                                                            if (ref($row->{$sf}) eq 'ARRAY');
354                                                  }                                                  }
355                                          } @{ $rec->{$fld} };  
356                                            } else {
357                                                    $self->{_stats}->{repeatable}->{ $fld }++;
358                                            }
359                                  }                                  }
360                          } keys %{ $rec };                          }
361                  }                  }
362    
363                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
# Line 314  sub open { Line 371  sub open {
371          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
372          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
373    
374            # save for dump
375            $self->{ll_db} = $ll_db;
376    
377          return $size;          return $size;
378  }  }
379    
# Line 353  sub fetch { Line 413  sub fetch {
413    
414          my $rec;          my $rec;
415    
416          if ($self->{low_mem}) {          if ($self->{load_row}) {
417                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
418          } else {          } else {
419                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
420          }          }
# Line 409  First record in database has position 1. Line 469  First record in database has position 1.
469    
470  sub seek {  sub seek {
471          my $self = shift;          my $self = shift;
472          my $pos = shift || return;          my $pos = shift;
473    
474          my $log = $self->_get_logger();          my $log = $self->_get_logger();
475    
476            $log->logconfess("called without pos") unless defined($pos);
477    
478          if ($pos < 1) {          if ($pos < 1) {
479                  $log->warn("seek before first record");                  $log->warn("seek before first record");
480                  $pos = 1;                  $pos = 1;
# Line 451  sub stats { Line 513  sub stats {
513                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
514                          $max_fld = $v if ($v > $max_fld);                          $max_fld = $v if ($v > $max_fld);
515    
516                          my $o = sprintf("%4d %d ~", $f, $v);                          my $o = sprintf("%4s %d ~", $f, $v);
517    
518                          if (defined($s->{sf}->{$f})) {                          if (defined($s->{sf}->{$f})) {
519                                  map {                                  map {
520                                          $o .= sprintf(" %s:%d", $_, $s->{sf}->{$f}->{$_});                                          $o .= sprintf(" %s:%d%s", $_,
521                                                    $s->{sf}->{$f}->{$_}->{count},
522                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
523                                            );
524                                  } sort keys %{ $s->{sf}->{$f} };                                  } sort keys %{ $s->{sf}->{$f} };
525                          }                          }
526    
# Line 464  sub stats { Line 529  sub stats {
529                          }                          }
530    
531                          $o;                          $o;
532                  } sort { $a <=> $b } keys %{ $s->{fld} }                  } sort { $a cmp $b } keys %{ $s->{fld} }
533          );          );
534    
535          $log->debug( sub { Dumper($s) } );          $log->debug( sub { dump($s) } );
536    
537          return $out;          return $out;
538  }  }
539    
540  =head1 MEMORY USAGE  =head2 dump_ascii
541    
542    Display humanly readable dump of record
543    
544    =cut
545    
546    sub dump_ascii {
547            my $self = shift;
548    
549            return unless $self->{ll_db};
550    
551  C<low_mem> options is double-edged sword. If enabled, WebPAC          if ($self->{ll_db}->can('dump_rec')) {
552  will run on memory constraint machines (which doesn't have enough                  return $self->{ll_db}->dump_ascii( $self->{pos} );
553  physical RAM to create memory structure for whole source database).          } else {
554                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
555  If your machine has 512Mb or more of RAM and database is around 10000 records,          }
556  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.  
557    
558    =head2 modify_record_regexps
559    
560    Generate hash with regexpes to be applied using l<filter>.
561    
562      my $regexpes = $input->modify_record_regexps(
563                    900 => { '^a' => { ' : ' => '^b' } },
564                    901 => { '*' => { '^b' => ' ; ' } },
565      );
566    
567    =cut
568    
569    sub _get_regex {
570            my ($sf,$from,$to) = @_;
571    
572            # protect /
573            $from =~ s!/!\\/!gs;
574            $to =~ s!/!\\/!gs;
575    
576            if ($from =~ m/^regex:(.+)$/) {
577                    $from = $1;
578            } else {
579                    $from = '\Q' . $from . '\E';
580            }
581            if ($sf =~ /^\^/) {
582                    return
583                            's/\Q'. $sf .'\E([^\^]*?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
584            } else {
585                    return
586                            's/'. $from .'/'. $to .'/g';
587            }
588    }
589    
590    sub modify_record_regexps {
591            my $self = shift;
592            my $modify_record = {@_};
593    
594            my $regexpes;
595    
596            my $log = $self->_get_logger();
597    
598            foreach my $f (keys %$modify_record) {
599                    $log->debug("field: $f");
600    
601                    foreach my $sf (keys %{ $modify_record->{$f} }) {
602                            $log->debug("subfield: $sf");
603    
604                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
605                                    my $to = $modify_record->{$f}->{$sf}->{$from};
606                                    #die "no field?" unless defined($to);
607                                    $log->debug("transform: |$from| -> |$to|");
608    
609                                    my $regex = _get_regex($sf,$from,$to);
610                                    push @{ $regexpes->{$f} }, $regex;
611                                    $log->debug("regex: $regex");
612                            }
613                    }
614            }
615    
616            return $regexpes;
617    }
618    
619    =head2 modify_file_regexps
620    
621    Generate hash with regexpes to be applied using l<filter> from
622    pseudo hash/yaml format for regex mappings.
623    
624    It should be obvious:
625    
626            200
627              '^a'
628                ' : ' => '^e'
629                ' = ' => '^d'
630    
631    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
632    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
633    
634      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
635    
636    On undef path it will just return.
637    
638    =cut
639    
640    sub modify_file_regexps {
641            my $self = shift;
642    
643            my $modify_path = shift || return;
644    
645            my $log = $self->_get_logger();
646    
647            my $regexpes;
648    
649            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
650    
651            my ($f,$sf);
652    
653            while(<$fh>) {
654                    chomp;
655                    next if (/^#/ || /^\s*$/);
656    
657                    if (/^\s*(\d+)\s*$/) {
658                            $f = $1;
659                            $log->debug("field: $f");
660                            next;
661                    } elsif (/^\s*'([^']*)'\s*$/) {
662                            $sf = $1;
663                            $log->die("can't define subfiled before field in: $_") unless ($f);
664                            $log->debug("subfield: $sf");
665                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
666                            my ($from,$to) = ($1, $2);
667    
668                            $log->debug("transform: |$from| -> |$to|");
669    
670                            my $regex = _get_regex($sf,$from,$to);
671                            push @{ $regexpes->{$f} }, $regex;
672                            $log->debug("regex: $regex");
673                    }
674            }
675    
676            return $regexpes;
677    }
678    
679  =head1 AUTHOR  =head1 AUTHOR
680    
# Line 509  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 682  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
682    
683  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
684    
685  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
686    
687  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
688  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.513  
changed lines
  Added in v.797
  ViewVC Help
Powered by ViewVC 1.1.26