/[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 292 by dpavlin, Sun Dec 18 23:34:30 2005 UTC revision 799 by dpavlin, Sun Feb 4 15:09:01 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 Encode qw/from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
# Line 15  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.03  Version 0.17
20    
21  =cut  =cut
22    
23  our $VERSION = '0.03';  our $VERSION = '0.17';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 38  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,          );
47                  lookup => $lookup_obj,  
48                  low_mem => 1,          $db->open( path => '/path/to/database' );
49      );          print "database size: ",$db->size,"\n";
50            while (my $rec = $db->fetch) {
51      $db->open('/path/to/database');                  # do something with $rec
52      print "database size: ",$db->size,"\n";          }
     while (my $rec = $db->fetch) {  
     }  
53    
54    
55    
# 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',
65          low_mem => 1,          recode => 'char pairs',
66            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    
76  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  C<recode> is optional string constisting of character or words pairs that
77    should be replaced in input stream.
78    
79    C<no_progress_bar> disables progress bar output on C<STDOUT>
80    
81  This function will also call low-level C<init> if it exists with same  This function will also call low-level C<init> if it exists with same
82  parametars.  parametars.
# Line 87  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}";  
                         $log->logwarn($missing);  
                         $self->{$subclass} = sub { warn "$missing\n" };  
                 } 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                  $log->logdie("DBM::Deep error: $!") unless ($db);          $module_path =~ s#::#/#g;
100            $module_path .= '.pm';
101            $log->debug("require low-level module $self->{module} from $module_path");
102    
103                  if ($db->error()) {          require $module_path;
                         $log->logdie("can't open '$db_file' under low_mem: ",$db->error());  
                 } else {  
                         $log->debug("using file '$db_file' for DBM::Deep");  
                 }  
104    
105                  $self->{'db'} = $db;          $self->{'encoding'} ||= 'ISO-8859-2';
         }  
106    
107          $self ? return $self : return undef;          $self ? return $self : return undef;
108  }  }
# Line 148  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,
121          lookup => $lookup_obj,          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    
147  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
148    
149    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 173  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 182  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;
201            my $recode_regex;
202            my $recode_map;
203    
204            if ($self->{recode}) {
205                    my @r = split(/\s/, $self->{recode});
206                    if ($#r % 2 != 1) {
207                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
208                    } else {
209                            while (@r) {
210                                    my $from = shift @r;
211                                    my $to = shift @r;
212                                    $recode_map->{$from} = $to;
213                            }
214    
215                            $recode_regex = join '|' => keys %{ $recode_map };
216    
217                            $log->debug("using recode regex: $recode_regex");
218                    }
219    
220            }
221    
222            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 ($db, $size) = $self->{open_db}->( $self,          my $ll_db = $class->new(
235                  path => $arg->{path},                  path => $arg->{path},
236    #               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 ($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;
256          }          }
257    
258          my $offset = 1;          my $from_rec = 1;
259          my $limit = $size;          my $to_rec = $size;
260    
261          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
262                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
263                  $offset = $s;                  $from_rec = $s;
264          } else {          } else {
265                  $self->{offset} = $offset;                  $self->{offset} = $from_rec;
266          }          }
267    
268          if ($self->{limit}) {          if ($self->{limit}) {
269                  $log->info("limiting to ",$self->{limit}," records");                  $log->debug("limiting to ",$self->{limit}," records");
270                  $limit = $offset + $self->{limit} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
271                  $limit = $size if ($limit > $size);                  $to_rec = $size if ($to_rec > $size);
272          }          }
273    
274          # store size for later          # store size for later
275          $self->{size} = ($limit - $offset) ? ($limit - $offset + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
276    
277          $log->info("processing $self->{size} records in $code_page, convert to $self->{code_page}");          $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 = $offset; $pos <= $limit; $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,$debug) = @_;
286    #                               return unless defined($l);
287    #                               return $l unless ($rec_regex && $f_nr);
288    
289                                    warn "-=> $f_nr ## $l\n" if ($debug);
290                                    $log->debug("-=> $f_nr ## $l");
291    
292                                    # codepage conversion and recode_regex
293                                    from_to($l, $code_page, $self->{'encoding'});
294                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
295    
296                                    # apply regexps
297                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
298                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
299                                            my $c = 0;
300                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
301                                                    my $old_l = $l;
302                                                    eval '$l =~ ' . $r;
303                                                    if ($old_l ne $l) {
304                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
305                                                            warn "*** $r |$old_l| -> |$l|\n" if ($debug);
306                                                    }
307                                                    $log->error("error applying regex: $r") if ($@);
308                                            }
309                                    }
310    
311                                    $log->debug("<=- $f_nr ## $l");
312                                    warn "<=- $f_nr ## $l\n" if ($debug);
313                                    return $l;
314                    });
315    
316                    $log->debug(sub { dump($rec) });
317    
318                  if (! $rec) {                  if (! $rec) {
319                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 233  sub open { Line 321  sub open {
321                  }                  }
322    
323                  # store                  # store
324                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
325                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
326                                    id => $pos,
327                                    row => $rec,
328                            });
329                  } else {                  } else {
330                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
331                  }                  }
332    
333                  # create lookup                  # create lookup
334                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
335    
336                    # update counters for statistics
337                    if ($self->{stats}) {
338    
339                            # fetch clean record with regexpes applied for statistics
340                            my $rec = $ll_db->fetch_rec($pos);
341    
342                  $self->progress_bar($pos,$limit);                          foreach my $fld (keys %{ $rec }) {
343                                    $self->{_stats}->{fld}->{ $fld }++;
344    
345                                    $log->logdie("invalid record fild $fld, not ARRAY")
346                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
347            
348                                    foreach my $row (@{ $rec->{$fld} }) {
349    
350                                            if (ref($row) eq 'HASH') {
351    
352                                                    foreach my $sf (keys %{ $row }) {
353                                                            next if ($sf eq 'subfields');
354                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
355                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
356                                                                            if (ref($row->{$sf}) eq 'ARRAY');
357                                                    }
358    
359                                            } else {
360                                                    $self->{_stats}->{repeatable}->{ $fld }++;
361                                            }
362                                    }
363                            }
364                    }
365    
366                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
367    
368          }          }
369    
# Line 250  sub open { Line 371  sub open {
371          $self->{last_pcnt} = 0;          $self->{last_pcnt} = 0;
372    
373          # store max mfn and return it.          # store max mfn and return it.
374          $self->{max_pos} = $limit;          $self->{max_pos} = $to_rec;
375          $log->debug("max_pos: $limit");          $log->debug("max_pos: $to_rec");
376    
377            # save for dump
378            $self->{ll_db} = $ll_db;
379    
380          return $size;          return $size;
381  }  }
# Line 288  sub fetch { Line 412  sub fetch {
412                  return;                  return;
413          }          }
414    
415          $self->progress_bar($mfn,$self->{max_pos});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
416    
417          my $rec;          my $rec;
418    
419          if ($self->{low_mem}) {          if ($self->{load_row}) {
420                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
421          } else {          } else {
422                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
423          }          }
# Line 348  First record in database has position 1. Line 472  First record in database has position 1.
472    
473  sub seek {  sub seek {
474          my $self = shift;          my $self = shift;
475          my $pos = shift || return;          my $pos = shift;
476    
477          my $log = $self->_get_logger();          my $log = $self->_get_logger();
478    
479            $log->logconfess("called without pos") unless defined($pos);
480    
481          if ($pos < 1) {          if ($pos < 1) {
482                  $log->warn("seek before first record");                  $log->warn("seek before first record");
483                  $pos = 1;                  $pos = 1;
# Line 363  sub seek { Line 489  sub seek {
489          return $self->{pos} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
490  }  }
491    
492    =head2 stats
493    
494  =head1 MEMORY USAGE  Dump statistics about field and subfield usage
495    
496  C<low_mem> options is double-edged sword. If enabled, WebPAC    print $input->stats;
 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.  
497    
498    =cut
499    
500    sub stats {
501            my $self = shift;
502    
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 { dump($s) } );
539    
540            return $out;
541    }
542    
543    =head2 dump_ascii
544    
545    Display humanly readable dump of record
546    
547    =cut
548    
549    sub dump_ascii {
550            my $self = shift;
551    
552            return unless $self->{ll_db};
553    
554            if ($self->{ll_db}->can('dump_rec')) {
555                    return $self->{ll_db}->dump_ascii( $self->{pos} );
556            } else {
557                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
558            }
559    }
560    
561    =head2 modify_record_regexps
562    
563    Generate hash with regexpes to be applied using L<filter>.
564    
565      my $regexpes = $input->modify_record_regexps(
566                    900 => { '^a' => { ' : ' => '^b' } },
567                    901 => { '*' => { '^b' => ' ; ' } },
568      );
569    
570    =cut
571    
572    sub _get_regex {
573            my ($sf,$from,$to) = @_;
574    
575            # protect /
576            $from =~ s!/!\\/!gs;
577            $to =~ s!/!\\/!gs;
578    
579            if ($from =~ m/^regex:(.+)$/) {
580                    $from = $1;
581            } else {
582                    $from = '\Q' . $from . '\E';
583            }
584            if ($sf =~ /^\^/) {
585                    return
586                            's/\Q'. $sf .'\E([^\^]*?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
587            } else {
588                    return
589                            's/'. $from .'/'. $to .'/g';
590            }
591    }
592    
593    sub modify_record_regexps {
594            my $self = shift;
595            my $modify_record = {@_};
596    
597            my $regexpes;
598    
599            my $log = $self->_get_logger();
600    
601            foreach my $f (keys %$modify_record) {
602                    $log->debug("field: $f");
603    
604                    foreach my $sf (keys %{ $modify_record->{$f} }) {
605                            $log->debug("subfield: $sf");
606    
607                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
608                                    my $to = $modify_record->{$f}->{$sf}->{$from};
609                                    #die "no field?" unless defined($to);
610                                    $log->debug("transform: |$from| -> |$to|");
611    
612                                    my $regex = _get_regex($sf,$from,$to);
613                                    push @{ $regexpes->{$f} }, $regex;
614                                    $log->debug("regex: $regex");
615                            }
616                    }
617            }
618    
619            return $regexpes;
620    }
621    
622    =head2 modify_file_regexps
623    
624    Generate hash with regexpes to be applied using L<filter> from
625    pseudo hash/yaml format for regex mappings.
626    
627    It should be obvious:
628    
629            200
630              '^a'
631                ' : ' => '^e'
632                ' = ' => '^d'
633    
634    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
635    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
636    
637      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
638    
639    On undef path it will just return.
640    
641    =cut
642    
643    sub modify_file_regexps {
644            my $self = shift;
645    
646            my $modify_path = shift || return;
647    
648            my $log = $self->_get_logger();
649    
650            my $regexpes;
651    
652            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
653    
654            my ($f,$sf);
655    
656            while(<$fh>) {
657                    chomp;
658                    next if (/^#/ || /^\s*$/);
659    
660                    if (/^\s*(\d+)\s*$/) {
661                            $f = $1;
662                            $log->debug("field: $f");
663                            next;
664                    } elsif (/^\s*'([^']*)'\s*$/) {
665                            $sf = $1;
666                            $log->die("can't define subfiled before field in: $_") unless ($f);
667                            $log->debug("subfield: $sf");
668                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
669                            my ($from,$to) = ($1, $2);
670    
671                            $log->debug("transform: |$from| -> |$to|");
672    
673                            my $regex = _get_regex($sf,$from,$to);
674                            push @{ $regexpes->{$f} }, $regex;
675                            $log->debug("regex: $regex");
676                    }
677            }
678    
679            return $regexpes;
680    }
681    
682  =head1 AUTHOR  =head1 AUTHOR
683    
# Line 401  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 685  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
685    
686  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
687    
688  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
689    
690  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
691  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.292  
changed lines
  Added in v.799
  ViewVC Help
Powered by ViewVC 1.1.26