/[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 285 by dpavlin, Sun Dec 18 21:06:39 2005 UTC revision 636 by dpavlin, Wed Sep 6 19:25:22 2006 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::Dumper;
11    use Encode qw/from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
15  WebPAC::Input - core module for input file format  WebPAC::Input - read different file formats into WebPAC
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.02  Version 0.12
20    
21  =cut  =cut
22    
23  our $VERSION = '0.02';  our $VERSION = '0.12';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
27  This module is used as base class for all database specific modules  This module implements input as database which have fixed and known
28  (basically, files which have one handle, fixed size while indexing and some  I<size> while indexing and single unique numeric identifier for database
29  kind of numeric idefinirier which goes from 1 to filesize).  position ranging from 1 to I<size>.
30    
31    Simply, something that is indexed by unmber from 1 .. I<size>.
32    
33    Examples of such databases are CDS/ISIS files, MARC files, lines in
34    text file, and so on.
35    
36    Specific file formats are implemented using low-level interface modules,
37    located in C<WebPAC::Input::*> namespace which export C<open_db>,
38    C<fetch_rec> and optional C<init> functions.
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(
45                    module => 'WebPAC::Input::ISIS',
46                    low_mem => 1,
47            );
48    
49            $db->open( path => '/path/to/database' );
50            print "database size: ",$db->size,"\n";
51            while (my $rec = $db->fetch) {
52                    # do something with $rec
53            }
54    
     my $db = WebPAC::Input->new(  
         format => 'NULL',  
         config => $config,  
         lookup => $lookup_obj,  
         low_mem => 1,  
     );  
55    
     $db->open('/path/to/database');  
     print "database size: ",$db->size,"\n";  
     while (my $row = $db->fetch) {  
         ...  
     }  
56    
57  =head1 FUNCTIONS  =head1 FUNCTIONS
58    
# Line 51  Perhaps a little code snippet. Line 61  Perhaps a little code snippet.
61  Create new input database object.  Create new input database object.
62    
63    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
64          format => 'NULL'          module => 'WebPAC::Input::MARC',
65          code_page => 'ISO-8859-2',          encoding => 'ISO-8859-2',
66          low_mem => 1,          low_mem => 1,
67            recode => 'char pairs',
68            no_progress_bar => 1,
69    );    );
70    
71  Optional parametar C<code_page> specify application code page (which will be  C<module> is low-level file format module. See L<WebPAC::Input::ISIS> and
72    L<WebPAC::Input::MARC>.
73    
74    Optional parametar C<encoding> specify application code page (which will be
75  used internally). This should probably be your terminal encoding, and by  used internally). This should probably be your terminal encoding, and by
76  default, it C<ISO-8859-2>.  default, it C<ISO-8859-2>.
77    
78  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).
79    
80    C<recode> is optional string constisting of character or words pairs that
81    should be replaced in input stream.
82    
83    C<no_progress_bar> disables progress bar output on C<STDOUT>
84    
85  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
86  parametars.  parametars.
87    
# Line 74  sub new { Line 94  sub new {
94    
95          my $log = $self->_get_logger;          my $log = $self->_get_logger;
96    
97            $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
98            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
99    
100            $log->logconfess("specify low-level file format module") unless ($self->{module});
101            my $module = $self->{module};
102            $module =~ s#::#/#g;
103            $module .= '.pm';
104            $log->debug("require low-level module $self->{module} from $module");
105    
106            require $module;
107            #eval $self->{module} .'->import';
108    
109          # check if required subclasses are implemented          # check if required subclasses are implemented
110          foreach my $subclass (qw/open_db fetch_rec/) {          foreach my $subclass (qw/open_db fetch_rec init/) {
111                  $log->logdie("missing implementation of $subclass") unless ($self->SUPER::can($subclass));                  my $n = $self->{module} . '::' . $subclass;
112                    if (! defined &{ $n }) {
113                            my $missing = "missing $subclass in $self->{module}";
114                            $self->{$subclass} = sub { $log->logwarn($missing) };
115                    } else {
116                            $self->{$subclass} = \&{ $n };
117                    }
118          }          }
119    
120          if ($self->can('init')) {          if ($self->{init}) {
121                  $log->debug("calling init");                  $log->debug("calling init");
122                  $self->init(@_);                  $self->{init}->($self, @_);
123          }          }
124    
125          $self->{'code_page'} ||= 'ISO-8859-2';          $self->{'encoding'} ||= 'ISO-8859-2';
126    
127          # running with low_mem flag? well, use DBM::Deep then.          # running with low_mem flag? well, use DBM::Deep then.
128          if ($self->{'low_mem'}) {          if ($self->{'low_mem'}) {
# Line 119  sub new { Line 157  sub new {
157    
158  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
159    
160   $isis->open(   $input->open(
161          path => '/path/to/database/file',          path => '/path/to/database/file',
162          code_page => '852',          code_page => 'cp852',
163          limit_mfn => 500,          limit => 500,
164          start_mfn => 6000,          offset => 6000,
165          lookup => $lookup_obj,          lookup => $lookup_obj,
166            stats => 1,
167            lookup_ref => sub {
168                    my ($k,$v) = @_;
169                    # store lookup $k => $v
170            },
171            modify_records => {
172                    900 => { '^a' => { ' : ' => '^b' } },
173                    901 => { '*' => { '^b' => ' ; ' } },
174            },
175            modify_file => 'conf/modify/mapping.map',
176   );   );
177    
178  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
179    
180    C<offset> is optional parametar to position at some offset before reading from database.
181    
182    C<limit> is optional parametar to read just C<limit> records from database
183    
184  If optional parametar C<start_mfn> is set, this will be first MFN to read  C<stats> create optional report about usage of fields and subfields
 from database (so you can skip beginning of your database if you need to).  
185    
186  If optional parametar C<limit_mfn> is set, it will read just 500 records  C<lookup_coderef> is closure to call when adding C<< key => 'value' >> combinations to
187  from database in example above.  lookup.
188    
189  Returns size of database, regardless of C<start_mfn> and C<limit_mfn>  C<modify_records> specify mapping from subfields to delimiters or from
190  parametars, see also C<$isis->size>.  delimiters to subfields, as well as oprations on fields (if subfield is
191    defined as C<*>.
192    
193    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
194    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
195    overrides C<modify_records> if both exists for same input.
196    
197    Returns size of database, regardless of C<offset> and C<limit>
198    parametars, see also C<size>.
199    
200  =cut  =cut
201    
# Line 146  sub open { Line 205  sub open {
205    
206          my $log = $self->_get_logger();          my $log = $self->_get_logger();
207    
208            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
209            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
210                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
211    
212          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
213          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
214    
215          # store data in object          # store data in object
216          $self->{'code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
217          foreach my $v (qw/path start_mfn limit_mfn/) {          foreach my $v (qw/path offset limit/) {
218                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
219          }          }
220    
221          # create Text::Iconv object          my $filter_ref;
222          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          my $recode_regex;
223            my $recode_map;
224    
225            if ($self->{recode}) {
226                    my @r = split(/\s/, $self->{recode});
227                    if ($#r % 2 != 1) {
228                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
229                    } else {
230                            while (@r) {
231                                    my $from = shift @r;
232                                    my $to = shift @r;
233                                    $recode_map->{$from} = $to;
234                            }
235    
236                            $recode_regex = join '|' => keys %{ $recode_map };
237    
238                            $log->debug("using recode regex: $recode_regex");
239                    }
240    
241            }
242    
243          my ($db, $size) = $self->open_db(          my $rec_regex;
244            if (my $p = $arg->{modify_file}) {
245                    $log->debug("using modify_file $p");
246                    $rec_regex = $self->modify_file_regexps( $p );
247            } elsif (my $h = $arg->{modify_records}) {
248                    $log->debug("using modify_records ", Dumper( $h ));
249                    $rec_regex = $self->modify_record_regexps(%{ $h });
250            }
251            $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
252    
253            my ($db, $size) = $self->{open_db}->( $self,
254                  path => $arg->{path},                  path => $arg->{path},
255    #               filter => sub {
256    #                       my ($l,$f_nr) = @_;
257    #                       return unless defined($l);
258    #                       from_to($l, $code_page, $self->{'encoding'});
259    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
260    #                       return $l;
261    #               },
262                    %{ $arg },
263          );          );
264    
265          unless ($db) {          unless (defined($db)) {
266                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
267                  return;                  return;
268          }          }
# Line 172  sub open { Line 272  sub open {
272                  return;                  return;
273          }          }
274    
275          my $startmfn = 1;          my $from_rec = 1;
276          my $maxmfn = $size;          my $to_rec = $size;
277    
278          if (my $s = $self->{start_mfn}) {          if (my $s = $self->{offset}) {
279                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
280                  $startmfn = $s;                  $from_rec = $s;
281          } else {          } else {
282                  $self->{start_mfn} = $startmfn;                  $self->{offset} = $from_rec;
283          }          }
284    
285          if ($self->{limit_mfn}) {          if ($self->{limit}) {
286                  $log->info("limiting to ",$self->{limit_mfn}," records");                  $log->debug("limiting to ",$self->{limit}," records");
287                  $maxmfn = $startmfn + $self->{limit_mfn} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
288                  $maxmfn = $size if ($maxmfn > $size);                  $to_rec = $size if ($to_rec > $size);
289          }          }
290    
291          # store size for later          # store size for later
292          $self->{size} = ($maxmfn - $startmfn) ? ($maxmfn - $startmfn + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
293    
294          $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]' : '');
295    
296          # read database          # read database
297          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
298    
299                    $log->debug("position: $pos\n");
300    
301                  $log->debug("mfn: $mfn\n");                  my $rec = $self->{fetch_rec}->($self, $db, $pos, sub {
302                                    my ($l,$f_nr) = @_;
303    #                               return unless defined($l);
304    #                               return $l unless ($rec_regex && $f_nr);
305    
306                                    $log->debug("-=> $f_nr ## $l");
307    
308                                    # codepage conversion and recode_regex
309                                    from_to($l, $code_page, $self->{'encoding'});
310                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
311    
312                                    # apply regexps
313                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
314                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
315                                            my $c = 0;
316                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
317                                                    my $old_l = $l;
318                                                    eval '$l =~ ' . $r;
319                                                    if ($old_l ne $l) {
320                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
321                                                    }
322                                                    $log->error("error applying regex: $r") if ($@);
323                                            }
324                                    }
325    
326                                    $log->debug("<=- $f_nr ## $l");
327                                    return $l;
328                    });
329    
330                  my $rec = $self->fetch_rec( $db, $mfn );                  $log->debug(sub { Dumper($rec) });
331    
332                  if (! $rec) {                  if (! $rec) {
333                          $log->warn("record $mfn empty? skipping...");                          $log->warn("record $pos empty? skipping...");
334                          next;                          next;
335                  }                  }
336    
337                  # store                  # store
338                  if ($self->{'low_mem'}) {                  if ($self->{low_mem}) {
339                          $self->{'db'}->put($mfn, $rec);                          $self->{db}->put($pos, $rec);
340                  } else {                  } else {
341                          $self->{'data'}->{$mfn} = $rec;                          $self->{data}->{$pos} = $rec;
342                  }                  }
343    
344                  # create lookup                  # create lookup
345                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
346    
347                  $self->progress_bar($mfn,$maxmfn);                  # update counters for statistics
348                    if ($self->{stats}) {
349    
350          }                          # fetch clean record with regexpes applied for statistics
351                            my $rec = $self->{fetch_rec}->($self, $db, $pos);
352    
353                            foreach my $fld (keys %{ $rec }) {
354                                    $self->{_stats}->{fld}->{ $fld }++;
355    
356                                    $log->logdie("invalid record fild $fld, not ARRAY")
357                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
358            
359                                    foreach my $row (@{ $rec->{$fld} }) {
360    
361                                            if (ref($row) eq 'HASH') {
362    
363                                                    foreach my $sf (keys %{ $row }) {
364                                                            next if ($sf eq 'subfields');
365                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
366                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
367                                                                            if (ref($row->{$sf}) eq 'ARRAY');
368                                                    }
369    
370                                            } else {
371                                                    $self->{_stats}->{repeatable}->{ $fld }++;
372                                            }
373                                    }
374                            }
375                    }
376    
377          $self->{'current_mfn'} = -1;                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
         $self->{'last_pcnt'} = 0;  
378    
379          $log->debug("max mfn: $maxmfn");          }
380    
381            $self->{pos} = -1;
382            $self->{last_pcnt} = 0;
383    
384          # store max mfn and return it.          # store max mfn and return it.
385          $self->{'max_mfn'} = $maxmfn;          $self->{max_pos} = $to_rec;
386            $log->debug("max_pos: $to_rec");
387    
388          return $size;          return $size;
389  }  }
# Line 246  sub fetch { Line 404  sub fetch {
404    
405          my $log = $self->_get_logger();          my $log = $self->_get_logger();
406    
407          $log->logconfess("it seems that you didn't load database!") unless ($self->{'current_mfn'});          $log->logconfess("it seems that you didn't load database!") unless ($self->{pos});
408    
409          if ($self->{'current_mfn'} == -1) {          if ($self->{pos} == -1) {
410                  $self->{'current_mfn'} = $self->{'start_mfn'};                  $self->{pos} = $self->{offset};
411          } else {          } else {
412                  $self->{'current_mfn'}++;                  $self->{pos}++;
413          }          }
414    
415          my $mfn = $self->{'current_mfn'};          my $mfn = $self->{pos};
416    
417          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{max_pos}) {
418                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{pos} = $self->{max_pos};
419                  $log->debug("at EOF");                  $log->debug("at EOF");
420                  return;                  return;
421          }          }
422    
423          $self->progress_bar($mfn,$self->{'max_mfn'});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
424    
425          my $rec;          my $rec;
426    
427          if ($self->{'low_mem'}) {          if ($self->{low_mem}) {
428                  $rec = $self->{'db'}->get($mfn);                  $rec = $self->{db}->get($mfn);
429          } else {          } else {
430                  $rec = $self->{'data'}->{$mfn};                  $rec = $self->{data}->{$mfn};
431          }          }
432    
433          $rec ||= 0E0;          $rec ||= 0E0;
# Line 287  First record in database has position 1. Line 445  First record in database has position 1.
445    
446  sub pos {  sub pos {
447          my $self = shift;          my $self = shift;
448          return $self->{'current_mfn'};          return $self->{pos};
449  }  }
450    
451    
# Line 301  Result from this function can be used to Line 459  Result from this function can be used to
459    
460   foreach my $mfn ( 1 ... $isis->size ) { ... }   foreach my $mfn ( 1 ... $isis->size ) { ... }
461    
462  because it takes into account C<start_mfn> and C<limit_mfn>.  because it takes into account C<offset> and C<limit>.
463    
464  =cut  =cut
465    
466  sub size {  sub size {
467          my $self = shift;          my $self = shift;
468          return $self->{'size'};          return $self->{size};
469  }  }
470    
471  =head2 seek  =head2 seek
# Line 329  sub seek { Line 487  sub seek {
487          if ($pos < 1) {          if ($pos < 1) {
488                  $log->warn("seek before first record");                  $log->warn("seek before first record");
489                  $pos = 1;                  $pos = 1;
490          } elsif ($pos > $self->{'max_mfn'}) {          } elsif ($pos > $self->{max_pos}) {
491                  $log->warn("seek beyond last record");                  $log->warn("seek beyond last record");
492                  $pos = $self->{'max_mfn'};                  $pos = $self->{max_pos};
493            }
494    
495            return $self->{pos} = (($pos - 1) || -1);
496    }
497    
498    =head2 stats
499    
500    Dump statistics about field and subfield usage
501    
502      print $input->stats;
503    
504    =cut
505    
506    sub stats {
507            my $self = shift;
508    
509            my $log = $self->_get_logger();
510    
511            my $s = $self->{_stats};
512            if (! $s) {
513                    $log->warn("called stats, but there is no statistics collected");
514                    return;
515            }
516    
517            my $max_fld = 0;
518    
519            my $out = join("\n",
520                    map {
521                            my $f = $_ || die "no field";
522                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
523                            $max_fld = $v if ($v > $max_fld);
524    
525                            my $o = sprintf("%4s %d ~", $f, $v);
526    
527                            if (defined($s->{sf}->{$f})) {
528                                    map {
529                                            $o .= sprintf(" %s:%d%s", $_,
530                                                    $s->{sf}->{$f}->{$_}->{count},
531                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
532                                            );
533                                    } sort keys %{ $s->{sf}->{$f} };
534                            }
535    
536                            if (my $v_r = $s->{repeatable}->{$f}) {
537                                    $o .= " ($v_r)" if ($v_r != $v);
538                            }
539    
540                            $o;
541                    } sort { $a cmp $b } keys %{ $s->{fld} }
542            );
543    
544            $log->debug( sub { Dumper($s) } );
545    
546            return $out;
547    }
548    
549    =head2 modify_record_regexps
550    
551    Generate hash with regexpes to be applied using l<filter>.
552    
553      my $regexpes = $input->modify_record_regexps(
554                    900 => { '^a' => { ' : ' => '^b' } },
555                    901 => { '*' => { '^b' => ' ; ' } },
556      );
557    
558    =cut
559    
560    sub _get_regex {
561            my ($sf,$from,$to) = @_;
562            if ($sf =~ /^\^/) {
563                    return
564                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
565            } else {
566                    return
567                            's/\Q'. $from .'\E/'. $to .'/g';
568          }          }
569    }
570    
571    sub modify_record_regexps {
572            my $self = shift;
573            my $modify_record = {@_};
574    
575            my $regexpes;
576    
577          return $self->{'current_mfn'} = (($pos - 1) || -1);          my $log = $self->_get_logger();
578    
579            foreach my $f (keys %$modify_record) {
580                    $log->debug("field: $f");
581    
582                    foreach my $sf (keys %{ $modify_record->{$f} }) {
583                            $log->debug("subfield: $sf");
584    
585                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
586                                    my $to = $modify_record->{$f}->{$sf}->{$from};
587                                    #die "no field?" unless defined($to);
588                                    $log->debug("transform: |$from| -> |$to|");
589    
590                                    my $regex = _get_regex($sf,$from,$to);
591                                    push @{ $regexpes->{$f} }, $regex;
592                                    $log->debug("regex: $regex");
593                            }
594                    }
595            }
596    
597            return $regexpes;
598  }  }
599    
600    =head2 modify_file_regexps
601    
602    Generate hash with regexpes to be applied using l<filter> from
603    pseudo hash/yaml format for regex mappings.
604    
605    It should be obvious:
606    
607            200
608              '^a'
609                ' : ' => '^e'
610                ' = ' => '^d'
611    
612    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
613    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
614    
615      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
616    
617    On undef path it will just return.
618    
619    =cut
620    
621    sub modify_file_regexps {
622            my $self = shift;
623    
624            my $modify_path = shift || return;
625    
626            my $log = $self->_get_logger();
627    
628            my $regexpes;
629    
630            CORE::open(my $fh, $modify_path) || $log->die("can't open modify file $modify_path: $!");
631    
632            my ($f,$sf);
633    
634            while(<$fh>) {
635                    chomp;
636                    next if (/^#/ || /^\s*$/);
637    
638                    if (/^\s*(\d+)\s*$/) {
639                            $f = $1;
640                            $log->debug("field: $f");
641                            next;
642                    } elsif (/^\s*'([^']*)'\s*$/) {
643                            $sf = $1;
644                            $log->die("can't define subfiled before field in: $_") unless ($f);
645                            $log->debug("subfield: $sf");
646                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
647                            my ($from,$to) = ($1, $2);
648    
649                            $log->debug("transform: |$from| -> |$to|");
650    
651                            my $regex = _get_regex($sf,$from,$to);
652                            push @{ $regexpes->{$f} }, $regex;
653                            $log->debug("regex: $regex");
654                    }
655            }
656    
657            return $regexpes;
658    }
659    
660  =head1 MEMORY USAGE  =head1 MEMORY USAGE
661    
# Line 375  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 694  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
694    
695  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
696    
697  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
698    
699  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
700  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.285  
changed lines
  Added in v.636
  ViewVC Help
Powered by ViewVC 1.1.26