/[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 416 by dpavlin, Sun Feb 26 23:21:50 2006 UTC revision 823 by dpavlin, Wed Apr 11 12:22:37 2007 UTC
# Line 3  package WebPAC::Input; Line 3  package WebPAC::Input;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6    use blib;
7    
8  use WebPAC::Common;  use WebPAC::Common;
9  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
10  use Text::Iconv;  use Data::Dump qw/dump/;
11  use Data::Dumper;  use Encode qw/from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
# Line 14  WebPAC::Input - read different file form Line 16  WebPAC::Input - read different file form
16    
17  =head1 VERSION  =head1 VERSION
18    
19  Version 0.04  Version 0.18
20    
21  =cut  =cut
22    
23  our $VERSION = '0.04';  our $VERSION = '0.18';
24    
25  =head1 SYNOPSIS  =head1 SYNOPSIS
26    
# Line 37  C<fetch_rec> and optional C<init> functi Line 39  C<fetch_rec> and optional C<init> functi
39    
40  Perhaps a little code snippet.  Perhaps a little code snippet.
41    
42      use WebPAC::Input;          use WebPAC::Input;
43    
44      my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
45          module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
46                  config => $config,          );
                 lookup => $lookup_obj,  
                 low_mem => 1,  
     );  
47    
48      $db->open('/path/to/database');          $db->open( path => '/path/to/database' );
49          print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
50          while (my $rec = $db->fetch) {          while (my $rec = $db->fetch) {
51                  # do something with $rec                  # do something with $rec
# Line 62  Create new input database object. Line 61  Create new input database object.
61    
62    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
63          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
64          code_page => 'ISO-8859-2',          encoding => 'ISO-8859-2',
         low_mem => 1,  
65          recode => 'char pairs',          recode => 'char pairs',
66            no_progress_bar => 1,
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 88  sub new { Line 90  sub new {
90    
91          my $log = $self->_get_logger;          my $log = $self->_get_logger;
92    
93          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
94          my $module = $self->{module};          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if ($self->{lookup});
95          $module =~ s#::#/#g;          $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if ($self->{low_mem});
         $module .= '.pm';  
         $log->debug("require low-level module $self->{module} from $module");  
   
         require $module;  
         #eval $self->{module} .'->import';  
   
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init/) {  
                 my $n = $self->{module} . '::' . $subclass;  
                 if (! defined &{ $n }) {  
                         my $missing = "missing $subclass in $self->{module}";  
                         $self->{$subclass} = sub { $log->logwarn($missing) };  
                 } else {  
                         $self->{$subclass} = \&{ $n };  
                 }  
         }  
   
         if ($self->{init}) {  
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
         }  
96    
97          $self->{'code_page'} ||= 'ISO-8859-2';          $log->logconfess("specify low-level file format module") unless ($self->{module});
98            my $module_path = $self->{module};
99          # running with low_mem flag? well, use DBM::Deep then.          $module_path =~ s#::#/#g;
100          if ($self->{'low_mem'}) {          $module_path .= '.pm';
101                  $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");          $log->debug("require low-level module $self->{module} from $module_path");
   
                 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;  
102    
103                  my $db = new DBM::Deep $db_file;          require $module_path;
104    
105                  $log->logdie("DBM::Deep error: $!") unless ($db);          $self->{'encoding'} ||= 'ISO-8859-2';
   
                 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;  
         }  
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;          my $filter_ref;
201            my $recode_regex;
202            my $recode_map;
203    
204          if ($self->{recode}) {          if ($self->{recode}) {
205                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
206                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
207                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");                          $log->logwarn("recode needs even number of elements (some number of valid pairs)");
208                  } else {                  } else {
                         my $recode;  
209                          while (@r) {                          while (@r) {
210                                  my $from = shift @r;                                  my $from = shift @r;
211                                  my $to = shift @r;                                  my $to = shift @r;
212                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
213                          }                          }
214    
215                          my $regex = join '|' => keys %{ $recode };                          $recode_regex = join '|' => keys %{ $recode_map };
   
                         $log->debug("using recode regex: $regex");  
                           
                         $filter_ref = sub {  
                                 my $t = shift;  
                                 $t =~ s/($regex)/$recode->{$1}/g;  
                                 return $t;  
                         };  
216    
217                            $log->debug("using recode regex: $recode_regex");
218                  }                  }
219    
220          }          }
221    
222          my ($db, $size) = $self->{open_db}->( $self,          my $rec_regex;
223            if (my $p = $arg->{modify_file}) {
224                    $log->debug("using modify_file $p");
225                    $rec_regex = $self->modify_file_regexps( $p );
226            } elsif (my $h = $arg->{modify_records}) {
227                    $log->debug("using modify_records ", sub { dump( $h ) });
228                    $rec_regex = $self->modify_record_regexps(%{ $h });
229            }
230            $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
231    
232            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
233    
234            my $ll_db = $class->new(
235                  path => $arg->{path},                  path => $arg->{path},
236                  filter => $filter_ref,  #               filter => sub {
237    #                       my ($l,$f_nr) = @_;
238    #                       return unless defined($l);
239    #                       from_to($l, $code_page, $self->{'encoding'});
240    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
241    #                       return $l;
242    #               },
243                    %{ $arg },
244          );          );
245    
246          unless ($db) {          unless (defined($ll_db)) {
247                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
248                  return;                  return;
249          }          }
250    
251            my $size = $ll_db->size;
252    
253          unless ($size) {          unless ($size) {
254                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
255                  return;                  return;
# Line 232  sub open { Line 259  sub open {
259          my $to_rec = $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                  $from_rec = $s;                  $from_rec = $s;
264          } else {          } else {
265                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec;
# Line 247  sub open { Line 274  sub open {
274          # store size for later          # store size for later
275          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
276    
277          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}");          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
278    
279          # read database          # read database
280          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
281    
282                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
283    
284                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
285                                    my ($l,$f_nr,$debug) = @_;
286    #                               return unless defined($l);
287    #                               return $l unless ($rec_regex && $f_nr);
288    
289                                    return unless ( defined($l) && defined($f_nr) );
290    
291                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
292                                    $log->debug("-=> $f_nr ## $l");
293    
294                                    # codepage conversion and recode_regex
295                                    from_to($l, $code_page, $self->{'encoding'});
296                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
297    
298                                    # apply regexps
299                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
300                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
301                                            my $c = 0;
302                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
303                                                    my $old_l = $l;
304                                                    $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
305                                                    eval '$l =~ ' . $r->{regex};
306                                                    if ($old_l ne $l) {
307                                                            my $d = "|$old_l| -> |$l| "; # . $r->{regex};
308                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
309                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
310                                                            $log->debug("MODIFY $d");
311                                                            warn "*** $d\n" if ($debug);
312    
313                                                    }
314                                                    $log->error("error applying regex: $r") if ($@);
315                                            }
316                                    }
317    
318                                    $log->debug("<=- $f_nr ## |$l|");
319                                    warn "<=- $f_nr ## $l\n" if ($debug);
320                                    return $l;
321                    });
322    
323                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
324    
325                  if (! $rec) {                  if (! $rec) {
326                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 264  sub open { Line 328  sub open {
328                  }                  }
329    
330                  # store                  # store
331                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
332                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
333                                    id => $pos,
334                                    row => $rec,
335                            });
336                  } else {                  } else {
337                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
338                  }                  }
339    
340                  # create lookup                  # create lookup
341                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
342    
343                  $self->progress_bar($pos,$to_rec);                  # update counters for statistics
344                    if ($self->{stats}) {
345    
346                            # fetch clean record with regexpes applied for statistics
347                            my $rec = $ll_db->fetch_rec($pos);
348    
349                            foreach my $fld (keys %{ $rec }) {
350                                    $self->{_stats}->{fld}->{ $fld }++;
351    
352                                    $log->logdie("invalid record fild $fld, not ARRAY")
353                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
354            
355                                    foreach my $row (@{ $rec->{$fld} }) {
356    
357                                            if (ref($row) eq 'HASH') {
358    
359                                                    foreach my $sf (keys %{ $row }) {
360                                                            next if ($sf eq 'subfields');
361                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
362                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
363                                                                            if (ref($row->{$sf}) eq 'ARRAY');
364                                                    }
365    
366                                            } else {
367                                                    $self->{_stats}->{repeatable}->{ $fld }++;
368                                            }
369                                    }
370                            }
371                    }
372    
373                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
374    
375          }          }
376    
# Line 284  sub open { Line 381  sub open {
381          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
382          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
383    
384            # save for dump
385            $self->{ll_db} = $ll_db;
386    
387          return $size;          return $size;
388  }  }
389    
# Line 319  sub fetch { Line 419  sub fetch {
419                  return;                  return;
420          }          }
421    
422          $self->progress_bar($mfn,$self->{max_pos});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
423    
424          my $rec;          my $rec;
425    
426          if ($self->{low_mem}) {          if ($self->{load_row}) {
427                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
428          } else {          } else {
429                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
430          }          }
# Line 379  First record in database has position 1. Line 479  First record in database has position 1.
479    
480  sub seek {  sub seek {
481          my $self = shift;          my $self = shift;
482          my $pos = shift || return;          my $pos = shift;
483    
484          my $log = $self->_get_logger();          my $log = $self->_get_logger();
485    
486            $log->logconfess("called without pos") unless defined($pos);
487    
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;
# Line 394  sub seek { Line 496  sub seek {
496          return $self->{pos} = (($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  =head1 MEMORY USAGE          my $log = $self->_get_logger();
511    
512  C<low_mem> options is double-edged sword. If enabled, WebPAC          my $s = $self->{_stats};
513  will run on memory constraint machines (which doesn't have enough          if (! $s) {
514  physical RAM to create memory structure for whole source database).                  $log->warn("called stats, but there is no statistics collected");
515                    return;
516  If your machine has 512Mb or more of RAM and database is around 10000 records,          }
517  memory shouldn't be an issue. If you don't have enough physical RAM, you  
518  might consider using virtual memory (if your operating system is handling it          my $max_fld = 0;
519  well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle  
520  parsed structure of ISIS database (this is what C<low_mem> option does).          my $out = join("\n",
521                    map {
522  Hitting swap at end of reading source database is probably o.k. However,                          my $f = $_ || die "no field";
523  hitting swap before 90% will dramatically decrease performance and you will                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
524  be better off with C<low_mem> and using rest of availble memory for                          $max_fld = $v if ($v > $max_fld);
525  operating system disk cache (Linux is particuallary good about this).  
526  However, every access to database record will require disk access, so                          my $o = sprintf("%4s %d ~", $f, $v);
527  generation phase will be slower 10-100 times.  
528                            if (defined($s->{sf}->{$f})) {
529  Parsed structures are essential - you just have option to trade RAM memory                                  map {
530  (which is fast) for disk space (which is slow). Be sure to have planty of                                          $o .= sprintf(" %s:%d%s", $_,
531  disk space if you are using C<low_mem> and thus L<DBM::Deep>.                                                  $s->{sf}->{$f}->{$_}->{count},
532                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
533  However, when WebPAC is running on desktop machines (or laptops :-), it's                                          );
534  highly undesireable for system to start swapping. Using C<low_mem> option can                                  } sort keys %{ $s->{sf}->{$f} };
535  reduce WecPAC memory usage to around 64Mb for same database with lookup                          }
536  fields and sorted indexes which stay in RAM. Performance will suffer, but  
537  memory usage will really be minimal. It might be also more confortable to                          if (my $v_r = $s->{repeatable}->{$f}) {
538  run WebPAC reniced on those machines.                                  $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 { dump($s) } );
546    
547            return $out;
548    }
549    
550    =head2 dump_ascii
551    
552    Display humanly readable dump of record
553    
554    =cut
555    
556    sub dump_ascii {
557            my $self = shift;
558    
559            return unless $self->{ll_db};
560    
561            if ($self->{ll_db}->can('dump_rec')) {
562                    return $self->{ll_db}->dump_ascii( $self->{pos} );
563            } else {
564                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
565            }
566    }
567    
568    =head2 _get_regex
569    
570    Helper function called which create regexps to be execute on code.
571    
572      _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
573      _get_regex( 900, '^b', ' : ^b' );
574    
575    It supports perl regexps with C<regex:> prefix to from value and has
576    additional logic to skip empty subfields.
577    
578    =cut
579    
580    sub _get_regex {
581            my ($sf,$from,$to) = @_;
582    
583            # protect /
584            $from =~ s!/!\\/!gs;
585            $to =~ s!/!\\/!gs;
586    
587            if ($from =~ m/^regex:(.+)$/) {
588                    $from = $1;
589            } else {
590                    $from = '\Q' . $from . '\E';
591            }
592            if ($sf =~ /^\^/) {
593                    my $need_subfield_data = '*';   # no
594                    # if from is also subfield, require some data in between
595                    # to correctly skip empty subfields
596                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
597                    return
598                            's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
599            } else {
600                    return
601                            's/'. $from .'/'. $to .'/g';
602            }
603    }
604    
605    
606    =head2 modify_record_regexps
607    
608    Generate hash with regexpes to be applied using L<filter>.
609    
610      my $regexpes = $input->modify_record_regexps(
611                    900 => { '^a' => { ' : ' => '^b' } },
612                    901 => { '*' => { '^b' => ' ; ' } },
613      );
614    
615    =cut
616    
617    sub modify_record_regexps {
618            my $self = shift;
619            my $modify_record = {@_};
620    
621            my $regexpes;
622    
623            my $log = $self->_get_logger();
624    
625            foreach my $f (keys %$modify_record) {
626                    $log->debug("field: $f");
627    
628                    foreach my $sf (keys %{ $modify_record->{$f} }) {
629                            $log->debug("subfield: $sf");
630    
631                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
632                                    my $to = $modify_record->{$f}->{$sf}->{$from};
633                                    #die "no field?" unless defined($to);
634                                    my $d = "|$from| -> |$to|";
635                                    $log->debug("transform: $d");
636    
637                                    my $regex = _get_regex($sf,$from,$to);
638                                    push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
639                                    $log->debug("regex: $regex");
640                            }
641                    }
642            }
643    
644            return $regexpes;
645    }
646    
647    =head2 modify_file_regexps
648    
649    Generate hash with regexpes to be applied using L<filter> from
650    pseudo hash/yaml format for regex mappings.
651    
652    It should be obvious:
653    
654            200
655              '^a'
656                ' : ' => '^e'
657                ' = ' => '^d'
658    
659    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
660    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
661    
662      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
663    
664    On undef path it will just return.
665    
666    =cut
667    
668    sub modify_file_regexps {
669            my $self = shift;
670    
671            my $modify_path = shift || return;
672    
673            my $log = $self->_get_logger();
674    
675            my $regexpes;
676    
677            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
678    
679            my ($f,$sf);
680    
681            while(<$fh>) {
682                    chomp;
683                    next if (/^#/ || /^\s*$/);
684    
685                    if (/^\s*(\d+)\s*$/) {
686                            $f = $1;
687                            $log->debug("field: $f");
688                            next;
689                    } elsif (/^\s*'([^']*)'\s*$/) {
690                            $sf = $1;
691                            $log->die("can't define subfiled before field in: $_") unless ($f);
692                            $log->debug("subfield: $sf");
693                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
694                            my ($from,$to) = ($1, $2);
695    
696                            $log->debug("transform: |$from| -> |$to|");
697    
698                            my $regex = _get_regex($sf,$from,$to);
699                            push @{ $regexpes->{$f} }, {
700                                    regex => $regex,
701                                    file => $modify_path,
702                                    line => $.,
703                            };
704                            $log->debug("regex: $regex");
705                    }
706            }
707    
708            return $regexpes;
709    }
710    
711  =head1 AUTHOR  =head1 AUTHOR
712    
# Line 432  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 714  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
714    
715  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
716    
717  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
718    
719  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
720  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.416  
changed lines
  Added in v.823
  ViewVC Help
Powered by ViewVC 1.1.26