/[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 483 by dpavlin, Sun May 14 09:34:05 2006 UTC revision 1100 by dpavlin, Sat Aug 2 23:46:41 2008 UTC
# Line 3  package WebPAC::Input; Line 3  package WebPAC::Input;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6  use WebPAC::Common 0.03;  use blib;
7    
8    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/decode from_to/;
12    
13  =head1 NAME  =head1 NAME
14    
15  WebPAC::Input - read different file formats into WebPAC  WebPAC::Input - read different file formats into WebPAC
16    
 =head1 VERSION  
   
 Version 0.04  
   
17  =cut  =cut
18    
19  our $VERSION = '0.04';  our $VERSION = '0.19';
20    
21  =head1 SYNOPSIS  =head1 SYNOPSIS
22    
# Line 37  C<fetch_rec> and optional C<init> functi Line 35  C<fetch_rec> and optional C<init> functi
35    
36  Perhaps a little code snippet.  Perhaps a little code snippet.
37    
38      use WebPAC::Input;          use WebPAC::Input;
39    
40      my $db = WebPAC::Input->new(          my $db = WebPAC::Input->new(
41          module => 'WebPAC::Input::ISIS',                  module => 'WebPAC::Input::ISIS',
42                  config => $config,          );
                 lookup => $lookup_obj,  
                 low_mem => 1,  
     );  
43    
44      $db->open('/path/to/database');          $db->open( path => '/path/to/database' );
45          print "database size: ",$db->size,"\n";          print "database size: ",$db->size,"\n";
46          while (my $rec = $db->fetch) {          while (my $rec = $db->fetch) {
47                  # do something with $rec                  # do something with $rec
# Line 62  Create new input database object. Line 57  Create new input database object.
57    
58    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
59          module => 'WebPAC::Input::MARC',          module => 'WebPAC::Input::MARC',
         code_page => 'ISO-8859-2',  
         low_mem => 1,  
60          recode => 'char pairs',          recode => 'char pairs',
61          no_progress_bar => 1,          no_progress_bar => 1,
62            input_config => {
63                    mapping => [ 'foo', 'bar', 'baz' ],
64            },
65    );    );
66    
67  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
68  L<WebPAC::Input::MARC>.  L<WebPAC::Input::MARC>.
69    
 Optional parametar C<code_page> specify application code page (which will be  
 used internally). This should probably be your terminal encoding, and by  
 default, it C<ISO-8859-2>.  
   
 Default is not to use C<low_mem> options (see L<MEMORY USAGE> below).  
   
70  C<recode> is optional string constisting of character or words pairs that  C<recode> is optional string constisting of character or words pairs that
71  should be replaced in input stream.  should be replaced in input stream.
72    
# Line 94  sub new { Line 84  sub new {
84    
85          my $log = $self->_get_logger;          my $log = $self->_get_logger;
86    
87          $log->logconfess("specify low-level file format module") unless ($self->{module});          $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
88          my $module = $self->{module};          $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
89          $module =~ s#::#/#g;          $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_ref") if $self->{lookup};
90          $module .= '.pm';          $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if $self->{low_mem};
         $log->debug("require low-level module $self->{module} from $module");  
   
         require $module;  
         #eval $self->{module} .'->import';  
   
         # check if required subclasses are implemented  
         foreach my $subclass (qw/open_db fetch_rec init/) {  
                 my $n = $self->{module} . '::' . $subclass;  
                 if (! defined &{ $n }) {  
                         my $missing = "missing $subclass in $self->{module}";  
                         $self->{$subclass} = sub { $log->logwarn($missing) };  
                 } else {  
                         $self->{$subclass} = \&{ $n };  
                 }  
         }  
   
         if ($self->{init}) {  
                 $log->debug("calling init");  
                 $self->{init}->($self, @_);  
         }  
   
         $self->{'code_page'} ||= 'ISO-8859-2';  
   
         # running with low_mem flag? well, use DBM::Deep then.  
         if ($self->{'low_mem'}) {  
                 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");  
   
                 my $db_file = "data.db";  
   
                 if (-e $db_file) {  
                         unlink $db_file or $log->logdie("can't remove '$db_file' from last run");  
                         $log->debug("removed '$db_file' from last run");  
                 }  
   
                 require DBM::Deep;  
91    
92                  my $db = new DBM::Deep $db_file;          $log->logconfess("specify low-level file format module") unless ($self->{module});
93            my $module_path = $self->{module};
94            $module_path =~ s#::#/#g;
95            $module_path .= '.pm';
96            $log->debug("require low-level module $self->{module} from $module_path");
97    
98                  $log->logdie("DBM::Deep error: $!") unless ($db);          require $module_path;
   
                 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;  
         }  
99    
100          $self ? return $self : return undef;          $self ? return $self : return undef;
101  }  }
# Line 154  sub new { Line 104  sub new {
104    
105  This function will read whole database in memory and produce lookups.  This function will read whole database in memory and produce lookups.
106    
107     my $store;     # simple in-memory hash
108    
109   $input->open(   $input->open(
110          path => '/path/to/database/file',          path => '/path/to/database/file',
111          code_page => '852',          input_encoding => 'cp852',
112            strict_encoding => 0,
113          limit => 500,          limit => 500,
114          offset => 6000,          offset => 6000,
115          lookup => $lookup_obj,          stats => 1,
116            lookup_coderef => sub {
117                    my $rec = shift;
118                    # store lookups
119            },
120            modify_records => {
121                    900 => { '^a' => { ' : ' => '^b' } },
122                    901 => { '*' => { '^b' => ' ; ' } },
123            },
124            modify_file => 'conf/modify/mapping.map',
125            save_row => sub {
126                    my $a = shift;
127                    $store->{ $a->{id} } = $a->{row};
128            },
129            load_row => sub {
130                    my $a = shift;
131                    return defined($store->{ $a->{id} }) &&
132                            $store->{ $a->{id} };
133            },
134    
135   );   );
136    
137  By default, C<code_page> is assumed to be C<852>.  By default, C<input_encoding> is assumed to be C<cp852>.
138    
139  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.
140    
141  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
142    
143    C<stats> create optional report about usage of fields and subfields
144    
145    C<lookup_coderef> is closure to called to save data into lookups
146    
147    C<modify_records> specify mapping from subfields to delimiters or from
148    delimiters to subfields, as well as oprations on fields (if subfield is
149    defined as C<*>.
150    
151    C<modify_file> is alternative for C<modify_records> above which preserves order and offers
152    (hopefully) simplier sintax than YAML or perl (see L</modify_file_regex>). This option
153    overrides C<modify_records> if both exists for same input.
154    
155    C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
156    is documented in example above.
157    
158    C<strict_encoding> should really default to 1, but it doesn't for now.
159    
160  Returns size of database, regardless of C<offset> and C<limit>  Returns size of database, regardless of C<offset> and C<limit>
161  parametars, see also C<size>.  parametars, see also C<size>.
162    
# Line 178  sub open { Line 167  sub open {
167          my $arg = {@_};          my $arg = {@_};
168    
169          my $log = $self->_get_logger();          my $log = $self->_get_logger();
170            $log->debug( "arguments: ",dump( $arg ));
171    
172            $log->logconfess("encoding argument is not suppored any more.") if $self->{encoding};
173            $log->logconfess("code_page argument is not suppored any more.") if $self->{code_page};
174            $log->logconfess("lookup argument is not suppored any more. rewrite call to lookup_coderef") if ($arg->{lookup});
175            $log->logconfess("lookup_coderef must be CODE, not ",ref($arg->{lookup_coderef}))
176                    if ($arg->{lookup_coderef} && ref($arg->{lookup_coderef}) ne 'CODE');
177    
178            $log->debug( $arg->{lookup_coderef} ? '' : 'not ', "using lookup_coderef");
179    
180          $log->logcroak("need path") if (! $arg->{'path'});          $log->logcroak("need path") if (! $arg->{'path'});
181          my $code_page = $arg->{'code_page'} || '852';          my $input_encoding = $arg->{'input_encoding'} || $self->{'input_encoding'} || 'cp852';
182    
183          # store data in object          # store data in object
         $self->{'input_code_page'} = $code_page;  
184          foreach my $v (qw/path offset limit/) {          foreach my $v (qw/path offset limit/) {
185                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
186          }          }
187    
188          # create Text::Iconv object          if ($arg->{load_row} || $arg->{save_row}) {
189          $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 (
190                            ref($arg->{load_row}) eq 'CODE' &&
191                            ref($arg->{save_row}) eq 'CODE'
192                    );
193                    $self->{load_row} = $arg->{load_row};
194                    $self->{save_row} = $arg->{save_row};
195                    $log->debug("using load_row and save_row instead of in-memory hash");
196            }
197    
198          my $filter_ref;          my $filter_ref;
199            my $recode_regex;
200            my $recode_map;
201    
202          if ($self->{recode}) {          if ($self->{recode}) {
203                  my @r = split(/\s/, $self->{recode});                  my @r = split(/\s/, $self->{recode});
204                  if ($#r % 2 != 1) {                  if ($#r % 2 != 1) {
205                          $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)");
206                  } else {                  } else {
                         my $recode;  
207                          while (@r) {                          while (@r) {
208                                  my $from = shift @r;                                  my $from = shift @r;
209                                  my $to = shift @r;                                  my $to = shift @r;
210                                  $recode->{$from} = $to;                                  $recode_map->{$from} = $to;
211                          }                          }
212    
213                          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;  
                         };  
214    
215                            $log->debug("using recode regex: $recode_regex");
216                  }                  }
217    
218          }          }
219    
220          my ($db, $size) = $self->{open_db}->( $self,          my $rec_regex;
221            if (my $p = $arg->{modify_file}) {
222                    $log->debug("using modify_file $p");
223                    $rec_regex = $self->modify_file_regexps( $p );
224            } elsif (my $h = $arg->{modify_records}) {
225                    $log->debug("using modify_records ", sub { dump( $h ) });
226                    $rec_regex = $self->modify_record_regexps(%{ $h });
227            }
228            $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
229    
230            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
231    
232            my $ll_db = $class->new(
233                  path => $arg->{path},                  path => $arg->{path},
234                  filter => $filter_ref,                  input_config => $arg->{input_config} || $self->{input_config},
235    #               filter => sub {
236    #                       my ($l,$f_nr) = @_;
237    #                       return unless defined($l);
238    #                       $l = decode($input_encoding, $l);
239    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
240    #                       return $l;
241    #               },
242                    %{ $arg },
243          );          );
244    
245          unless ($db) {          unless (defined($ll_db)) {
246                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
247                  return;                  return;
248          }          }
249    
250            my $size = $ll_db->size;
251    
252          unless ($size) {          unless ($size) {
253                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
254                  return;                  return;
# Line 238  sub open { Line 258  sub open {
258          my $to_rec = $size;          my $to_rec = $size;
259    
260          if (my $s = $self->{offset}) {          if (my $s = $self->{offset}) {
261                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
262                  $from_rec = $s;                  $from_rec = $s;
263          } else {          } else {
264                  $self->{offset} = $from_rec;                  $self->{offset} = $from_rec;
# Line 253  sub open { Line 273  sub open {
273          # store size for later          # store size for later
274          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
275    
276          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{code_page}");          my $strict_encoding = $arg->{strict_encoding} || $self->{strict_encoding}; ## FIXME should be 1 really
277    
278            $log->info("processing $self->{size}/$size records [$from_rec-$to_rec]",
279                    " encoding $input_encoding ", $strict_encoding ? ' [strict]' : '',
280                    $self->{stats} ? ' [stats]' : '',
281            );
282    
283          # read database          # read database
284          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
285    
286                  $log->debug("position: $pos\n");                  $log->debug("position: $pos\n");
287    
288                  my $rec = $self->{fetch_rec}->($self, $db, $pos );                  my $rec = $ll_db->fetch_rec($pos, sub {
289                                    my ($l,$f_nr,$debug) = @_;
290    #                               return unless defined($l);
291    #                               return $l unless ($rec_regex && $f_nr);
292    
293                                    return unless ( defined($l) && defined($f_nr) );
294    
295                                    warn "-=> $f_nr ## |$l|\n" if ($debug);
296                                    $log->debug("-=> $f_nr ## $l");
297    
298                                    # codepage conversion and recode_regex
299    #                               $l = decode($input_encoding, $l, 1);
300                                    from_to( $l, $input_encoding, 'utf-8', 1 );
301                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
302    
303                                    # apply regexps
304                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
305                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
306                                            my $c = 0;
307                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
308                                                    my $old_l = $l;
309                                                    $log->logconfess("expected regex in ", dump( $r )) unless defined($r->{regex});
310                                                    eval '$l =~ ' . $r->{regex};
311                                                    if ($old_l ne $l) {
312                                                            my $d = "|$old_l| -> |$l| "; # . $r->{regex};
313                                                            $d .= ' +' . $r->{line} . ' ' . $r->{file} if defined($r->{line});
314                                                            $d .= ' ' . $r->{debug} if defined($r->{debug});
315                                                            $log->debug("MODIFY $d");
316                                                            warn "*** $d\n" if ($debug);
317    
318                                                    }
319                                                    $log->error("error applying regex: $r") if ($@);
320                                            }
321                                    }
322    
323                                    $log->debug("<=- $f_nr ## |$l|");
324                                    warn "<=- $f_nr ## $l\n" if ($debug);
325                                    return $l;
326                    });
327    
328                  $log->debug(sub { Dumper($rec) });                  $log->debug(sub { dump($rec) });
329    
330                  if (! $rec) {                  if (! $rec) {
331                          $log->warn("record $pos empty? skipping...");                          $log->warn("record $pos empty? skipping...");
# Line 270  sub open { Line 333  sub open {
333                  }                  }
334    
335                  # store                  # store
336                  if ($self->{low_mem}) {                  if ($self->{save_row}) {
337                          $self->{db}->put($pos, $rec);                          $self->{save_row}->({
338                                    id => $pos,
339                                    row => $rec,
340                            });
341                  } else {                  } else {
342                          $self->{data}->{$pos} = $rec;                          $self->{data}->{$pos} = $rec;
343                  }                  }
344    
345                  # create lookup                  # create lookup
346                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
347    
348                    # update counters for statistics
349                    if ($self->{stats}) {
350    
351                            # fetch clean record with regexpes applied for statistics
352                            my $rec = $ll_db->fetch_rec($pos);
353    
354                            foreach my $fld (keys %{ $rec }) {
355                                    $self->{_stats}->{fld}->{ $fld }++;
356    
357                                    #$log->logdie("invalid record fild $fld, not ARRAY")
358                                    next unless (ref($rec->{ $fld }) eq 'ARRAY');
359            
360                                    foreach my $row (@{ $rec->{$fld} }) {
361    
362                                            if (ref($row) eq 'HASH') {
363    
364                                                    foreach my $sf (keys %{ $row }) {
365                                                            next if ($sf eq 'subfields');
366                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
367                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
368                                                                            if (ref($row->{$sf}) eq 'ARRAY');
369                                                    }
370    
371                                            } else {
372                                                    $self->{_stats}->{repeatable}->{ $fld }++;
373                                            }
374                                    }
375                            }
376                    }
377    
378                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});                  $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
379    
# Line 290  sub open { Line 386  sub open {
386          $self->{max_pos} = $to_rec;          $self->{max_pos} = $to_rec;
387          $log->debug("max_pos: $to_rec");          $log->debug("max_pos: $to_rec");
388    
389            # save for dump
390            $self->{ll_db} = $ll_db;
391    
392          return $size;          return $size;
393  }  }
394    
# Line 329  sub fetch { Line 428  sub fetch {
428    
429          my $rec;          my $rec;
430    
431          if ($self->{low_mem}) {          if ($self->{load_row}) {
432                  $rec = $self->{db}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
433          } else {          } else {
434                  $rec = $self->{data}->{$mfn};                  $rec = $self->{data}->{$mfn};
435          }          }
# Line 385  First record in database has position 1. Line 484  First record in database has position 1.
484    
485  sub seek {  sub seek {
486          my $self = shift;          my $self = shift;
487          my $pos = shift || return;          my $pos = shift;
488    
489          my $log = $self->_get_logger();          my $log = $self->_get_logger();
490    
491            $log->logconfess("called without pos") unless defined($pos);
492    
493          if ($pos < 1) {          if ($pos < 1) {
494                  $log->warn("seek before first record");                  $log->warn("seek before first record");
495                  $pos = 1;                  $pos = 1;
# Line 400  sub seek { Line 501  sub seek {
501          return $self->{pos} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
502  }  }
503    
504    =head2 stats
505    
506    Dump statistics about field and subfield usage
507    
508  =head1 MEMORY USAGE    print $input->stats;
509    
510    =cut
511    
512  C<low_mem> options is double-edged sword. If enabled, WebPAC  sub stats {
513  will run on memory constraint machines (which doesn't have enough          my $self = shift;
514  physical RAM to create memory structure for whole source database).  
515            my $log = $self->_get_logger();
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          my $s = $self->{_stats};
518  might consider using virtual memory (if your operating system is handling it          if (! $s) {
519  well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle                  $log->warn("called stats, but there is no statistics collected");
520  parsed structure of ISIS database (this is what C<low_mem> option does).                  return;
521            }
522  Hitting swap at end of reading source database is probably o.k. However,  
523  hitting swap before 90% will dramatically decrease performance and you will          my $max_fld = 0;
524  be better off with C<low_mem> and using rest of availble memory for  
525  operating system disk cache (Linux is particuallary good about this).          my $out = join("\n",
526  However, every access to database record will require disk access, so                  map {
527  generation phase will be slower 10-100 times.                          my $f = $_;
528                            die "no field in ", dump( $s->{fld} ) unless defined( $f );
529  Parsed structures are essential - you just have option to trade RAM memory                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
530  (which is fast) for disk space (which is slow). Be sure to have planty of                          $max_fld = $v if ($v > $max_fld);
531  disk space if you are using C<low_mem> and thus L<DBM::Deep>.  
532                            my $o = sprintf("%4s %d ~", $f, $v);
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                          if (defined($s->{sf}->{$f})) {
535  reduce WecPAC memory usage to around 64Mb for same database with lookup                                  my @subfields = keys %{ $s->{sf}->{$f} };
536  fields and sorted indexes which stay in RAM. Performance will suffer, but                                  map {
537  memory usage will really be minimal. It might be also more confortable to                                          $o .= sprintf(" %s:%d%s", $_,
538  run WebPAC reniced on those machines.                                                  $s->{sf}->{$f}->{$_}->{count},
539                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
540                                            );
541                                    } (
542                                            # first indicators and other special subfields
543                                            sort( grep { length($_)  > 1 } @subfields ),
544                                            # then subfileds (single char)
545                                            sort( grep { length($_) == 1 } @subfields ),
546                                    );
547                            }
548    
549                            if (my $v_r = $s->{repeatable}->{$f}) {
550                                    $o .= " ($v_r)" if ($v_r != $v);
551                            }
552    
553                            $o;
554                    } sort {
555                            if ( $a =~ m/^\d+$/ && $b =~ m/^\d+$/ ) {
556                                    $a <=> $b
557                            } else {
558                                    $a cmp $b
559                            }
560                    } keys %{ $s->{fld} }
561            );
562    
563            $log->debug( sub { dump($s) } );
564    
565            return $out;
566    }
567    
568    =head2 dump_ascii
569    
570    Display humanly readable dump of record
571    
572    =cut
573    
574    sub dump_ascii {
575            my $self = shift;
576    
577            return unless $self->{ll_db};
578    
579            if ($self->{ll_db}->can('dump_ascii')) {
580                    return $self->{ll_db}->dump_ascii( $self->{pos} );
581            } else {
582                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
583            }
584    }
585    
586    =head2 _get_regex
587    
588    Helper function called which create regexps to be execute on code.
589    
590      _get_regex( 900, 'regex:[0-9]+' ,'numbers' );
591      _get_regex( 900, '^b', ' : ^b' );
592    
593    It supports perl regexps with C<regex:> prefix to from value and has
594    additional logic to skip empty subfields.
595    
596    =cut
597    
598    sub _get_regex {
599            my ($sf,$from,$to) = @_;
600    
601            # protect /
602            $from =~ s!/!\\/!gs;
603            $to =~ s!/!\\/!gs;
604    
605            if ($from =~ m/^regex:(.+)$/) {
606                    $from = $1;
607            } else {
608                    $from = '\Q' . $from . '\E';
609            }
610            if ($sf =~ /^\^/) {
611                    my $need_subfield_data = '*';   # no
612                    # if from is also subfield, require some data in between
613                    # to correctly skip empty subfields
614                    $need_subfield_data = '+' if ($from =~ m/^\\Q\^/);
615                    return
616                            's/\Q'. $sf .'\E([^\^]' . $need_subfield_data . '?)'. $from .'([^\^]*?)/'. $sf .'$1'. $to .'$2/';
617            } else {
618                    return
619                            's/'. $from .'/'. $to .'/g';
620            }
621    }
622    
623    
624    =head2 modify_record_regexps
625    
626    Generate hash with regexpes to be applied using L<filter>.
627    
628      my $regexpes = $input->modify_record_regexps(
629                    900 => { '^a' => { ' : ' => '^b' } },
630                    901 => { '*' => { '^b' => ' ; ' } },
631      );
632    
633    =cut
634    
635    sub modify_record_regexps {
636            my $self = shift;
637            my $modify_record = {@_};
638    
639            my $regexpes;
640    
641            my $log = $self->_get_logger();
642    
643            foreach my $f (keys %$modify_record) {
644                    $log->debug("field: $f");
645    
646                    foreach my $sf (keys %{ $modify_record->{$f} }) {
647                            $log->debug("subfield: $sf");
648    
649                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
650                                    my $to = $modify_record->{$f}->{$sf}->{$from};
651                                    #die "no field?" unless defined($to);
652                                    my $d = "|$from| -> |$to|";
653                                    $log->debug("transform: $d");
654    
655                                    my $regex = _get_regex($sf,$from,$to);
656                                    push @{ $regexpes->{$f} }, { regex => $regex, debug => $d };
657                                    $log->debug("regex: $regex");
658                            }
659                    }
660            }
661    
662            return $regexpes;
663    }
664    
665    =head2 modify_file_regexps
666    
667    Generate hash with regexpes to be applied using L<filter> from
668    pseudo hash/yaml format for regex mappings.
669    
670    It should be obvious:
671    
672            200
673              '^a'
674                ' : ' => '^e'
675                ' = ' => '^d'
676    
677    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
678    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
679    
680      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
681    
682    On undef path it will just return.
683    
684    =cut
685    
686    sub modify_file_regexps {
687            my $self = shift;
688    
689            my $modify_path = shift || return;
690    
691            my $log = $self->_get_logger();
692    
693            my $regexpes;
694    
695            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
696    
697            my ($f,$sf);
698    
699            while(<$fh>) {
700                    chomp;
701                    next if (/^#/ || /^\s*$/);
702    
703                    if (/^\s*(\d+)\s*$/) {
704                            $f = $1;
705                            $log->debug("field: $f");
706                            next;
707                    } elsif (/^\s*'([^']*)'\s*$/) {
708                            $sf = $1;
709                            $log->die("can't define subfiled before field in: $_") unless ($f);
710                            $log->debug("subfield: $sf");
711                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
712                            my ($from,$to) = ($1, $2);
713    
714                            $log->debug("transform: |$from| -> |$to|");
715    
716                            my $regex = _get_regex($sf,$from,$to);
717                            push @{ $regexpes->{$f} }, {
718                                    regex => $regex,
719                                    file => $modify_path,
720                                    line => $.,
721                            };
722                            $log->debug("regex: $regex");
723                    }
724            }
725    
726            return $regexpes;
727    }
728    
729  =head1 AUTHOR  =head1 AUTHOR
730    
# Line 438  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 732  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
732    
733  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
734    
735  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
736    
737  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
738  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.483  
changed lines
  Added in v.1100
  ViewVC Help
Powered by ViewVC 1.1.26