/[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 760 by dpavlin, Wed Oct 25 15:56:44 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.13
20    
21  =cut  =cut
22    
23  our $VERSION = '0.02';  our $VERSION = '0.13';
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          # check if required subclasses are implemented          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
98          foreach my $subclass (qw/open_db fetch_rec/) {          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
                 $log->logdie("missing implementation of $subclass") unless ($self->SUPER::can($subclass));  
         }  
99    
100          if ($self->can('init')) {          $log->logconfess("specify low-level file format module") unless ($self->{module});
101                  $log->debug("calling init");          my $module_path = $self->{module};
102                  $self->init(@_);          $module_path =~ s#::#/#g;
103          }          $module_path .= '.pm';
104            $log->debug("require low-level module $self->{module} from $module_path");
105    
106          $self->{'code_page'} ||= 'ISO-8859-2';          require $module_path;
107    
108          # running with low_mem flag? well, use DBM::Deep then.          # check if required subclasses are implemented
109          if ($self->{'low_mem'}) {          foreach my $subclass (qw/open_db fetch_rec init dump_rec/) {
110                  $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");                  # FIXME
   
                 my $db_file = "data.db";  
   
                 if (-e $db_file) {  
                         unlink $db_file or $log->logdie("can't remove '$db_file' from last run");  
                         $log->debug("removed '$db_file' from last run");  
                 }  
   
                 require DBM::Deep;  
   
                 my $db = new DBM::Deep $db_file;  
   
                 $log->logdie("DBM::Deep error: $!") unless ($db);  
   
                 if ($db->error()) {  
                         $log->logdie("can't open '$db_file' under low_mem: ",$db->error());  
                 } else {  
                         $log->debug("using file '$db_file' for DBM::Deep");  
                 }  
   
                 $self->{'db'} = $db;  
111          }          }
112    
113            $self->{'encoding'} ||= 'ISO-8859-2';
114    
115          $self ? return $self : return undef;          $self ? return $self : return undef;
116  }  }
117    
# Line 119  sub new { Line 119  sub new {
119    
120  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
121    
122   $isis->open(   $input->open(
123          path => '/path/to/database/file',          path => '/path/to/database/file',
124          code_page => '852',          code_page => 'cp852',
125          limit_mfn => 500,          limit => 500,
126          start_mfn => 6000,          offset => 6000,
127          lookup => $lookup_obj,          stats => 1,
128            lookup_coderef => sub {
129                    my $rec = shift;
130                    # store lookups
131            },
132            modify_records => {
133                    900 => { '^a' => { ' : ' => '^b' } },
134                    901 => { '*' => { '^b' => ' ; ' } },
135            },
136            modify_file => 'conf/modify/mapping.map',
137   );   );
138    
139  By default, C<code_page> is assumed to be C<852>.  By default, C<code_page> is assumed to be C<cp852>.
140    
141    C<offset> is optional parametar to position at some offset before reading from database.
142    
143    C<limit> is optional parametar to read just C<limit> records from database
144    
145    C<stats> create optional report about usage of fields and subfields
146    
147    C<lookup_coderef> is closure to called to save data into lookups
148    
149  If optional parametar C<start_mfn> is set, this will be first MFN to read  C<modify_records> specify mapping from subfields to delimiters or from
150  from database (so you can skip beginning of your database if you need to).  delimiters to subfields, as well as oprations on fields (if subfield is
151    defined as C<*>.
152    
153  If optional parametar C<limit_mfn> is set, it will read just 500 records  C<modify_file> is alternative for C<modify_records> above which preserves order and offers
154  from database in example above.  (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
155    overrides C<modify_records> if both exists for same input.
156    
157  Returns size of database, regardless of C<start_mfn> and C<limit_mfn>  Returns size of database, regardless of C<offset> and C<limit>
158  parametars, see also C<$isis->size>.  parametars, see also C<size>.
159    
160  =cut  =cut
161    
# Line 146  sub open { Line 165  sub open {
165    
166          my $log = $self->_get_logger();          my $log = $self->_get_logger();
167    
168            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
169            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
170                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
171    
172            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
173    
174          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
175          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || 'cp852';
176    
177          # store data in object          # store data in object
178          $self->{'code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
179          foreach my $v (qw/path start_mfn limit_mfn/) {          foreach my $v (qw/path offset limit/) {
180                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
181          }          }
182    
183          # create Text::Iconv object          my $filter_ref;
184          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});          my $recode_regex;
185            my $recode_map;
186    
187            if ($self->{recode}) {
188                    my @r = split(/\s/, $self->{recode});
189                    if ($#r % 2 != 1) {
190                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
191                    } else {
192                            while (@r) {
193                                    my $from = shift @r;
194                                    my $to = shift @r;
195                                    $recode_map->{$from} = $to;
196                            }
197    
198                            $recode_regex = join '|' => keys %{ $recode_map };
199    
200                            $log->debug("using recode regex: $recode_regex");
201                    }
202    
203            }
204    
205            my $rec_regex;
206            if (my $p = $arg->{modify_file}) {
207                    $log->debug("using modify_file $p");
208                    $rec_regex = $self->modify_file_regexps( $p );
209            } elsif (my $h = $arg->{modify_records}) {
210                    $log->debug("using modify_records ", Dumper( $h ));
211                    $rec_regex = $self->modify_record_regexps(%{ $h });
212            }
213            $log->debug("rec_regex: ", Dumper($rec_regex)) if ($rec_regex);
214    
215            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
216    
217          my ($db, $size) = $self->open_db(          my $ll_db = $class->new(
218                  path => $arg->{path},                  path => $arg->{path},
219    #               filter => sub {
220    #                       my ($l,$f_nr) = @_;
221    #                       return unless defined($l);
222    #                       from_to($l, $code_page, $self->{'encoding'});
223    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
224    #                       return $l;
225    #               },
226                    %{ $arg },
227          );          );
228    
229          unless ($db) {          unless (defined($ll_db)) {
230                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
231                  return;                  return;
232          }          }
233    
234            my $size = $ll_db->size;
235    
236          unless ($size) {          unless ($size) {
237                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
238                  return;                  return;
239          }          }
240    
241          my $startmfn = 1;          my $from_rec = 1;
242          my $maxmfn = $size;          my $to_rec = $size;
243    
244          if (my $s = $self->{start_mfn}) {          if (my $s = $self->{offset}) {
245                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
246                  $startmfn = $s;                  $from_rec = $s;
247          } else {          } else {
248                  $self->{start_mfn} = $startmfn;                  $self->{offset} = $from_rec;
249          }          }
250    
251          if ($self->{limit_mfn}) {          if ($self->{limit}) {
252                  $log->info("limiting to ",$self->{limit_mfn}," records");                  $log->debug("limiting to ",$self->{limit}," records");
253                  $maxmfn = $startmfn + $self->{limit_mfn} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
254                  $maxmfn = $size if ($maxmfn > $size);                  $to_rec = $size if ($to_rec > $size);
255          }          }
256    
257          # store size for later          # store size for later
258          $self->{size} = ($maxmfn - $startmfn) ? ($maxmfn - $startmfn + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
259    
260            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
261    
262            # turn on low_mem for databases with more than 100000 records!
263            if (! $self->{low_mem} && $size > 100000) {
264                    $log->warn("Using on-disk storage instead of memory for input data. This will affect performance.");
265                    $self->{low_mem}++;
266            }
267    
268            # running with low_mem flag? well, use DBM::Deep then.
269            if ($self->{'low_mem'}) {
270                    $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");
271    
272                    my $db_file = "data.db";
273    
274                    if (-e $db_file) {
275                            unlink $db_file or $log->logdie("can't remove '$db_file' from last run");
276                            $log->debug("removed '$db_file' from last run");
277                    }
278    
279                    require DBM::Deep;
280    
281                    my $db = new DBM::Deep $db_file;
282    
283          $log->info("processing $self->{size} records in $code_page, convert to $self->{code_page}");                  $log->logdie("DBM::Deep error: $!") unless ($db);
284    
285                    if ($db->error()) {
286                            $log->logdie("can't open '$db_file' under low_mem: ",$db->error());
287                    } else {
288                            $log->debug("using file '$db_file' for DBM::Deep");
289                    }
290    
291                    $self->{'db'} = $db;
292            }
293    
294          # read database          # read database
295          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
296    
297                  $log->debug("mfn: $mfn\n");                  $log->debug("position: $pos\n");
298    
299                  my $rec = $self->fetch_rec( $db, $mfn );                  my $rec = $ll_db->fetch_rec($pos, sub {
300                                    my ($l,$f_nr) = @_;
301    #                               return unless defined($l);
302    #                               return $l unless ($rec_regex && $f_nr);
303    
304                                    $log->debug("-=> $f_nr ## $l");
305    
306                                    # codepage conversion and recode_regex
307                                    from_to($l, $code_page, $self->{'encoding'});
308                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
309    
310                                    # apply regexps
311                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
312                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
313                                            my $c = 0;
314                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
315                                                    my $old_l = $l;
316                                                    eval '$l =~ ' . $r;
317                                                    if ($old_l ne $l) {
318                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
319                                                    }
320                                                    $log->error("error applying regex: $r") if ($@);
321                                            }
322                                    }
323    
324                                    $log->debug("<=- $f_nr ## $l");
325                                    return $l;
326                    });
327    
328                    $log->debug(sub { Dumper($rec) });
329    
330                  if (! $rec) {                  if (! $rec) {
331                          $log->warn("record $mfn empty? skipping...");                          $log->warn("record $pos empty? skipping...");
332                          next;                          next;
333                  }                  }
334    
335                  # store                  # store
336                  if ($self->{'low_mem'}) {                  if ($self->{low_mem}) {
337                          $self->{'db'}->put($mfn, $rec);                          $self->{db}->put($pos, $rec);
338                  } else {                  } else {
339                          $self->{'data'}->{$mfn} = $rec;                          $self->{data}->{$pos} = $rec;
340                  }                  }
341    
342                  # create lookup                  # create lookup
343                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
344    
345                  $self->progress_bar($mfn,$maxmfn);                  # update counters for statistics
346                    if ($self->{stats}) {
347    
348          }                          # fetch clean record with regexpes applied for statistics
349                            my $rec = $ll_db->fetch_rec($pos);
350    
351                            foreach my $fld (keys %{ $rec }) {
352                                    $self->{_stats}->{fld}->{ $fld }++;
353    
354                                    $log->logdie("invalid record fild $fld, not ARRAY")
355                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
356            
357                                    foreach my $row (@{ $rec->{$fld} }) {
358    
359                                            if (ref($row) eq 'HASH') {
360    
361                                                    foreach my $sf (keys %{ $row }) {
362                                                            next if ($sf eq 'subfields');
363                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
364                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
365                                                                            if (ref($row->{$sf}) eq 'ARRAY');
366                                                    }
367    
368                                            } else {
369                                                    $self->{_stats}->{repeatable}->{ $fld }++;
370                                            }
371                                    }
372                            }
373                    }
374    
375                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
376    
377          $self->{'current_mfn'} = -1;          }
         $self->{'last_pcnt'} = 0;  
378    
379          $log->debug("max mfn: $maxmfn");          $self->{pos} = -1;
380            $self->{last_pcnt} = 0;
381    
382          # store max mfn and return it.          # store max mfn and return it.
383          $self->{'max_mfn'} = $maxmfn;          $self->{max_pos} = $to_rec;
384            $log->debug("max_pos: $to_rec");
385    
386            # save for dump
387            $self->{ll_db} = $ll_db;
388    
389          return $size;          return $size;
390  }  }
# Line 246  sub fetch { Line 405  sub fetch {
405    
406          my $log = $self->_get_logger();          my $log = $self->_get_logger();
407    
408          $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});
409    
410          if ($self->{'current_mfn'} == -1) {          if ($self->{pos} == -1) {
411                  $self->{'current_mfn'} = $self->{'start_mfn'};                  $self->{pos} = $self->{offset};
412          } else {          } else {
413                  $self->{'current_mfn'}++;                  $self->{pos}++;
414          }          }
415    
416          my $mfn = $self->{'current_mfn'};          my $mfn = $self->{pos};
417    
418          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{max_pos}) {
419                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{pos} = $self->{max_pos};
420                  $log->debug("at EOF");                  $log->debug("at EOF");
421                  return;                  return;
422          }          }
423    
424          $self->progress_bar($mfn,$self->{'max_mfn'});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
425    
426          my $rec;          my $rec;
427    
428          if ($self->{'low_mem'}) {          if ($self->{low_mem}) {
429                  $rec = $self->{'db'}->get($mfn);                  $rec = $self->{db}->get($mfn);
430          } else {          } else {
431                  $rec = $self->{'data'}->{$mfn};                  $rec = $self->{data}->{$mfn};
432          }          }
433    
434          $rec ||= 0E0;          $rec ||= 0E0;
# Line 287  First record in database has position 1. Line 446  First record in database has position 1.
446    
447  sub pos {  sub pos {
448          my $self = shift;          my $self = shift;
449          return $self->{'current_mfn'};          return $self->{pos};
450  }  }
451    
452    
# Line 301  Result from this function can be used to Line 460  Result from this function can be used to
460    
461   foreach my $mfn ( 1 ... $isis->size ) { ... }   foreach my $mfn ( 1 ... $isis->size ) { ... }
462    
463  because it takes into account C<start_mfn> and C<limit_mfn>.  because it takes into account C<offset> and C<limit>.
464    
465  =cut  =cut
466    
467  sub size {  sub size {
468          my $self = shift;          my $self = shift;
469          return $self->{'size'};          return $self->{size};
470  }  }
471    
472  =head2 seek  =head2 seek
# Line 329  sub seek { Line 488  sub seek {
488          if ($pos < 1) {          if ($pos < 1) {
489                  $log->warn("seek before first record");                  $log->warn("seek before first record");
490                  $pos = 1;                  $pos = 1;
491          } elsif ($pos > $self->{'max_mfn'}) {          } elsif ($pos > $self->{max_pos}) {
492                  $log->warn("seek beyond last record");                  $log->warn("seek beyond last record");
493                  $pos = $self->{'max_mfn'};                  $pos = $self->{max_pos};
494          }          }
495    
496          return $self->{'current_mfn'} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
497  }  }
498    
499    =head2 stats
500    
501    Dump statistics about field and subfield usage
502    
503      print $input->stats;
504    
505    =cut
506    
507    sub stats {
508            my $self = shift;
509    
510            my $log = $self->_get_logger();
511    
512            my $s = $self->{_stats};
513            if (! $s) {
514                    $log->warn("called stats, but there is no statistics collected");
515                    return;
516            }
517    
518            my $max_fld = 0;
519    
520            my $out = join("\n",
521                    map {
522                            my $f = $_ || die "no field";
523                            my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
524                            $max_fld = $v if ($v > $max_fld);
525    
526                            my $o = sprintf("%4s %d ~", $f, $v);
527    
528                            if (defined($s->{sf}->{$f})) {
529                                    map {
530                                            $o .= sprintf(" %s:%d%s", $_,
531                                                    $s->{sf}->{$f}->{$_}->{count},
532                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
533                                            );
534                                    } sort keys %{ $s->{sf}->{$f} };
535                            }
536    
537                            if (my $v_r = $s->{repeatable}->{$f}) {
538                                    $o .= " ($v_r)" if ($v_r != $v);
539                            }
540    
541                            $o;
542                    } sort { $a cmp $b } keys %{ $s->{fld} }
543            );
544    
545            $log->debug( sub { Dumper($s) } );
546    
547            return $out;
548    }
549    
550    =head2 dump
551    
552    Display humanly readable dump of record
553    
554    =cut
555    
556    sub dump {
557            my $self = shift;
558    
559            return $self->{ll_db}->dump_rec( $self->{pos} );
560    
561    }
562    
563    =head2 modify_record_regexps
564    
565    Generate hash with regexpes to be applied using l<filter>.
566    
567      my $regexpes = $input->modify_record_regexps(
568                    900 => { '^a' => { ' : ' => '^b' } },
569                    901 => { '*' => { '^b' => ' ; ' } },
570      );
571    
572    =cut
573    
574    sub _get_regex {
575            my ($sf,$from,$to) = @_;
576            if ($sf =~ /^\^/) {
577                    return
578                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
579            } else {
580                    return
581                            's/\Q'. $from .'\E/'. $to .'/g';
582            }
583    }
584    
585    sub modify_record_regexps {
586            my $self = shift;
587            my $modify_record = {@_};
588    
589            my $regexpes;
590    
591            my $log = $self->_get_logger();
592    
593            foreach my $f (keys %$modify_record) {
594                    $log->debug("field: $f");
595    
596                    foreach my $sf (keys %{ $modify_record->{$f} }) {
597                            $log->debug("subfield: $sf");
598    
599                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
600                                    my $to = $modify_record->{$f}->{$sf}->{$from};
601                                    #die "no field?" unless defined($to);
602                                    $log->debug("transform: |$from| -> |$to|");
603    
604                                    my $regex = _get_regex($sf,$from,$to);
605                                    push @{ $regexpes->{$f} }, $regex;
606                                    $log->debug("regex: $regex");
607                            }
608                    }
609            }
610    
611            return $regexpes;
612    }
613    
614    =head2 modify_file_regexps
615    
616    Generate hash with regexpes to be applied using l<filter> from
617    pseudo hash/yaml format for regex mappings.
618    
619    It should be obvious:
620    
621            200
622              '^a'
623                ' : ' => '^e'
624                ' = ' => '^d'
625    
626    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
627    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
628    
629      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
630    
631    On undef path it will just return.
632    
633    =cut
634    
635    sub modify_file_regexps {
636            my $self = shift;
637    
638            my $modify_path = shift || return;
639    
640            my $log = $self->_get_logger();
641    
642            my $regexpes;
643    
644            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
645    
646            my ($f,$sf);
647    
648            while(<$fh>) {
649                    chomp;
650                    next if (/^#/ || /^\s*$/);
651    
652                    if (/^\s*(\d+)\s*$/) {
653                            $f = $1;
654                            $log->debug("field: $f");
655                            next;
656                    } elsif (/^\s*'([^']*)'\s*$/) {
657                            $sf = $1;
658                            $log->die("can't define subfiled before field in: $_") unless ($f);
659                            $log->debug("subfield: $sf");
660                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
661                            my ($from,$to) = ($1, $2);
662    
663                            $log->debug("transform: |$from| -> |$to|");
664    
665                            my $regex = _get_regex($sf,$from,$to);
666                            push @{ $regexpes->{$f} }, $regex;
667                            $log->debug("regex: $regex");
668                    }
669            }
670    
671            return $regexpes;
672    }
673    
674  =head1 MEMORY USAGE  =head1 MEMORY USAGE
675    
# Line 375  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 708  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
708    
709  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
710    
711  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
712    
713  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
714  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.285  
changed lines
  Added in v.760
  ViewVC Help
Powered by ViewVC 1.1.26