/[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 774 by dpavlin, Fri Nov 3 20:56:21 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::Dump qw/dump/;
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.16
20    
21  =cut  =cut
22    
23  our $VERSION = '0.02';  our $VERSION = '0.16';
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            );
47    
48            $db->open( path => '/path/to/database' );
49            print "database size: ",$db->size,"\n";
50            while (my $rec = $db->fetch) {
51                    # do something with $rec
52            }
53    
54    
     my $db = WebPAC::Input->new(  
         format => 'NULL',  
         config => $config,  
         lookup => $lookup_obj,  
         low_mem => 1,  
     );  
   
     $db->open('/path/to/database');  
     print "database size: ",$db->size,"\n";  
     while (my $row = $db->fetch) {  
         ...  
     }  
55    
56  =head1 FUNCTIONS  =head1 FUNCTIONS
57    
# Line 51  Perhaps a little code snippet. Line 60  Perhaps a little code snippet.
60  Create new input database object.  Create new input database object.
61    
62    my $db = new WebPAC::Input(    my $db = new WebPAC::Input(
63          format => 'NULL'          module => 'WebPAC::Input::MARC',
64          code_page => 'ISO-8859-2',          encoding => 'ISO-8859-2',
65          low_mem => 1,          recode => 'char pairs',
66            no_progress_bar => 1,
67    );    );
68    
69  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
70    L<WebPAC::Input::MARC>.
71    
72    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 74  sub new { Line 90  sub new {
90    
91          my $log = $self->_get_logger;          my $log = $self->_get_logger;
92    
93          # check if required subclasses are implemented          $log->logconfess("code_page argument is not suppored any more. change it to encoding") if ($self->{lookup});
94          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});
95                  $log->logdie("missing implementation of $subclass") unless ($self->SUPER::can($subclass));          $log->logconfess("low_mem argument is not suppored any more. rewrite it to load_row and save_row") if ($self->{low_mem});
96          }  
97            $log->logconfess("specify low-level file format module") unless ($self->{module});
98            my $module_path = $self->{module};
99            $module_path =~ s#::#/#g;
100            $module_path .= '.pm';
101            $log->debug("require low-level module $self->{module} from $module_path");
102    
103          if ($self->can('init')) {          require $module_path;
                 $log->debug("calling init");  
                 $self->init(@_);  
         }  
   
         $self->{'code_page'} ||= 'ISO-8859-2';  
104    
105          # running with low_mem flag? well, use DBM::Deep then.          $self->{'encoding'} ||= 'ISO-8859-2';
         if ($self->{'low_mem'}) {  
                 $log->info("running with low_mem which impacts performance (<32 Mb memory usage)");  
106    
107                  my $db_file = "data.db";          $self ? return $self : return undef;
108    }
109    
110                  if (-e $db_file) {  =head2 open
                         unlink $db_file or $log->logdie("can't remove '$db_file' from last run");  
                         $log->debug("removed '$db_file' from last run");  
                 }  
111    
112                  require DBM::Deep;  This function will read whole database in memory and produce lookups.
113    
114                  my $db = new DBM::Deep $db_file;   my $store;     # simple in-memory hash
115    
116                  $log->logdie("DBM::Deep error: $!") unless ($db);   $input->open(
117            path => '/path/to/database/file',
118            code_page => 'cp852',
119            limit => 500,
120            offset => 6000,
121            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                  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");  
                 }  
142    
143                  $self->{'db'} = $db;  By default, C<code_page> is assumed to be C<cp852>.
         }  
144    
145          $self ? return $self : return undef;  C<offset> is optional parametar to position at some offset before reading from database.
 }  
146    
147  =head2 open  C<limit> is optional parametar to read just C<limit> records from database
148    
149  This function will read whole database in memory and produce lookups.  C<stats> create optional report about usage of fields and subfields
150    
151   $isis->open(  C<lookup_coderef> is closure to called to save data into lookups
         path => '/path/to/database/file',  
         code_page => '852',  
         limit_mfn => 500,  
         start_mfn => 6000,  
         lookup => $lookup_obj,  
  );  
152    
153  By default, C<code_page> is assumed to be C<852>.  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  If optional parametar C<start_mfn> is set, this will be first MFN to read  C<modify_file> is alternative for C<modify_records> above which preserves order and offers
158  from database (so you can skip beginning of your database if you need to).  (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  If optional parametar C<limit_mfn> is set, it will read just 500 records  C<save_row> and C<load_row> are low-level implementation of store engine. Calling convention
162  from database in example above.  is documented in example above.
163    
164  Returns size of database, regardless of C<start_mfn> and C<limit_mfn>  Returns size of database, regardless of C<offset> and C<limit>
165  parametars, see also C<$isis->size>.  parametars, see also C<size>.
166    
167  =cut  =cut
168    
# Line 146  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->{'code_page'} = $code_page;          $self->{'input_code_page'} = $code_page;
186          foreach my $v (qw/path start_mfn limit_mfn/) {          foreach my $v (qw/path offset limit/) {
187                  $self->{$v} = $arg->{$v} if ($arg->{$v});                  $self->{$v} = $arg->{$v} if ($arg->{$v});
188          }          }
189    
190          # create Text::Iconv object          if ($arg->{load_row} || $arg->{save_row}) {
191          $self->{iconv} = Text::Iconv->new($code_page,$self->{'code_page'});                  $log->logconfess("save_row and load_row must be defined in pair and be CODE") unless (
192                            ref($arg->{load_row}) eq 'CODE' &&
193                            ref($arg->{save_row}) eq 'CODE'
194                    );
195                    $self->{load_row} = $arg->{load_row};
196                    $self->{save_row} = $arg->{save_row};
197                    $log->debug("using load_row and save_row instead of in-memory hash");
198            }
199    
200            my $filter_ref;
201            my $recode_regex;
202            my $recode_map;
203    
204            if ($self->{recode}) {
205                    my @r = split(/\s/, $self->{recode});
206                    if ($#r % 2 != 1) {
207                            $log->logwarn("recode needs even number of elements (some number of valid pairs)");
208                    } else {
209                            while (@r) {
210                                    my $from = shift @r;
211                                    my $to = shift @r;
212                                    $recode_map->{$from} = $to;
213                            }
214    
215          my ($db, $size) = $self->open_db(                          $recode_regex = join '|' => keys %{ $recode_map };
216    
217                            $log->debug("using recode regex: $recode_regex");
218                    }
219    
220            }
221    
222            my $rec_regex;
223            if (my $p = $arg->{modify_file}) {
224                    $log->debug("using modify_file $p");
225                    $rec_regex = $self->modify_file_regexps( $p );
226            } elsif (my $h = $arg->{modify_records}) {
227                    $log->debug("using modify_records ", sub { dump( $h ) });
228                    $rec_regex = $self->modify_record_regexps(%{ $h });
229            }
230            $log->debug("rec_regex: ", sub { dump($rec_regex) }) if ($rec_regex);
231    
232            my $class = $self->{module} || $log->logconfess("can't get low-level module name!");
233    
234            my $ll_db = $class->new(
235                  path => $arg->{path},                  path => $arg->{path},
236    #               filter => sub {
237    #                       my ($l,$f_nr) = @_;
238    #                       return unless defined($l);
239    #                       from_to($l, $code_page, $self->{'encoding'});
240    #                       $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
241    #                       return $l;
242    #               },
243                    %{ $arg },
244          );          );
245    
246          unless ($db) {          unless (defined($ll_db)) {
247                  $log->logwarn("can't open database $arg->{path}, skipping...");                  $log->logwarn("can't open database $arg->{path}, skipping...");
248                  return;                  return;
249          }          }
250    
251            my $size = $ll_db->size;
252    
253          unless ($size) {          unless ($size) {
254                  $log->logwarn("no records in database $arg->{path}, skipping...");                  $log->logwarn("no records in database $arg->{path}, skipping...");
255                  return;                  return;
256          }          }
257    
258          my $startmfn = 1;          my $from_rec = 1;
259          my $maxmfn = $size;          my $to_rec = $size;
260    
261          if (my $s = $self->{start_mfn}) {          if (my $s = $self->{offset}) {
262                  $log->info("skipping to MFN $s");                  $log->debug("skipping to MFN $s");
263                  $startmfn = $s;                  $from_rec = $s;
264          } else {          } else {
265                  $self->{start_mfn} = $startmfn;                  $self->{offset} = $from_rec;
266          }          }
267    
268          if ($self->{limit_mfn}) {          if ($self->{limit}) {
269                  $log->info("limiting to ",$self->{limit_mfn}," records");                  $log->debug("limiting to ",$self->{limit}," records");
270                  $maxmfn = $startmfn + $self->{limit_mfn} - 1;                  $to_rec = $from_rec + $self->{limit} - 1;
271                  $maxmfn = $size if ($maxmfn > $size);                  $to_rec = $size if ($to_rec > $size);
272          }          }
273    
274          # store size for later          # store size for later
275          $self->{size} = ($maxmfn - $startmfn) ? ($maxmfn - $startmfn + 1) : 0;          $self->{size} = ($to_rec - $from_rec) ? ($to_rec - $from_rec + 1) : 0;
276    
277          $log->info("processing $self->{size} records in $code_page, convert to $self->{code_page}");          $log->info("processing $self->{size}/$size records [$from_rec-$to_rec] convert $code_page -> $self->{encoding}", $self->{stats} ? ' [stats]' : '');
278    
279          # read database          # read database
280          for (my $mfn = $startmfn; $mfn <= $maxmfn; $mfn++) {          for (my $pos = $from_rec; $pos <= $to_rec; $pos++) {
281    
282                  $log->debug("mfn: $mfn\n");                  $log->debug("position: $pos\n");
283    
284                  my $rec = $self->fetch_rec( $db, $mfn );                  my $rec = $ll_db->fetch_rec($pos, sub {
285                                    my ($l,$f_nr) = @_;
286    #                               return unless defined($l);
287    #                               return $l unless ($rec_regex && $f_nr);
288    
289                                    $log->debug("-=> $f_nr ## $l");
290    
291                                    # codepage conversion and recode_regex
292                                    from_to($l, $code_page, $self->{'encoding'});
293                                    $l =~ s/($recode_regex)/$recode_map->{$1}/g if ($recode_regex && $recode_map);
294    
295                                    # apply regexps
296                                    if ($rec_regex && defined($rec_regex->{$f_nr})) {
297                                            $log->logconfess("regexps->{$f_nr} must be ARRAY") if (ref($rec_regex->{$f_nr}) ne 'ARRAY');
298                                            my $c = 0;
299                                            foreach my $r (@{ $rec_regex->{$f_nr} }) {
300                                                    my $old_l = $l;
301                                                    eval '$l =~ ' . $r;
302                                                    if ($old_l ne $l) {
303                                                            $log->debug("REGEX on $f_nr eval \$l =~ $r\n## old l: [$old_l]\n## new l: [$l]");
304                                                    }
305                                                    $log->error("error applying regex: $r") if ($@);
306                                            }
307                                    }
308    
309                                    $log->debug("<=- $f_nr ## $l");
310                                    return $l;
311                    });
312    
313                    $log->debug(sub { dump($rec) });
314    
315                  if (! $rec) {                  if (! $rec) {
316                          $log->warn("record $mfn empty? skipping...");                          $log->warn("record $pos empty? skipping...");
317                          next;                          next;
318                  }                  }
319    
320                  # store                  # store
321                  if ($self->{'low_mem'}) {                  if ($self->{save_row}) {
322                          $self->{'db'}->put($mfn, $rec);                          $self->{save_row}->({
323                                    id => $pos,
324                                    row => $rec,
325                            });
326                  } else {                  } else {
327                          $self->{'data'}->{$mfn} = $rec;                          $self->{data}->{$pos} = $rec;
328                  }                  }
329    
330                  # create lookup                  # create lookup
331                  $self->{'lookup'}->add( $rec ) if ($rec && $self->{'lookup'});                  $arg->{'lookup_coderef'}->( $rec ) if ($rec && $arg->{'lookup_coderef'});
332    
333                  $self->progress_bar($mfn,$maxmfn);                  # update counters for statistics
334                    if ($self->{stats}) {
335    
336          }                          # fetch clean record with regexpes applied for statistics
337                            my $rec = $ll_db->fetch_rec($pos);
338    
339                            foreach my $fld (keys %{ $rec }) {
340                                    $self->{_stats}->{fld}->{ $fld }++;
341    
342                                    $log->logdie("invalid record fild $fld, not ARRAY")
343                                            unless (ref($rec->{ $fld }) eq 'ARRAY');
344            
345                                    foreach my $row (@{ $rec->{$fld} }) {
346    
347                                            if (ref($row) eq 'HASH') {
348    
349                                                    foreach my $sf (keys %{ $row }) {
350                                                            next if ($sf eq 'subfields');
351                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{count}++;
352                                                            $self->{_stats}->{sf}->{ $fld }->{ $sf }->{repeatable}++
353                                                                            if (ref($row->{$sf}) eq 'ARRAY');
354                                                    }
355    
356                                            } else {
357                                                    $self->{_stats}->{repeatable}->{ $fld }++;
358                                            }
359                                    }
360                            }
361                    }
362    
363                    $self->progress_bar($pos,$to_rec) unless ($self->{no_progress_bar});
364    
365          $self->{'current_mfn'} = -1;          }
         $self->{'last_pcnt'} = 0;  
366    
367          $log->debug("max mfn: $maxmfn");          $self->{pos} = -1;
368            $self->{last_pcnt} = 0;
369    
370          # store max mfn and return it.          # store max mfn and return it.
371          $self->{'max_mfn'} = $maxmfn;          $self->{max_pos} = $to_rec;
372            $log->debug("max_pos: $to_rec");
373    
374            # save for dump
375            $self->{ll_db} = $ll_db;
376    
377          return $size;          return $size;
378  }  }
# Line 246  sub fetch { Line 393  sub fetch {
393    
394          my $log = $self->_get_logger();          my $log = $self->_get_logger();
395    
396          $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});
397    
398          if ($self->{'current_mfn'} == -1) {          if ($self->{pos} == -1) {
399                  $self->{'current_mfn'} = $self->{'start_mfn'};                  $self->{pos} = $self->{offset};
400          } else {          } else {
401                  $self->{'current_mfn'}++;                  $self->{pos}++;
402          }          }
403    
404          my $mfn = $self->{'current_mfn'};          my $mfn = $self->{pos};
405    
406          if ($mfn > $self->{'max_mfn'}) {          if ($mfn > $self->{max_pos}) {
407                  $self->{'current_mfn'} = $self->{'max_mfn'};                  $self->{pos} = $self->{max_pos};
408                  $log->debug("at EOF");                  $log->debug("at EOF");
409                  return;                  return;
410          }          }
411    
412          $self->progress_bar($mfn,$self->{'max_mfn'});          $self->progress_bar($mfn,$self->{max_pos}) unless ($self->{no_progress_bar});
413    
414          my $rec;          my $rec;
415    
416          if ($self->{'low_mem'}) {          if ($self->{load_row}) {
417                  $rec = $self->{'db'}->get($mfn);                  $rec = $self->{load_row}->({ id => $mfn });
418          } else {          } else {
419                  $rec = $self->{'data'}->{$mfn};                  $rec = $self->{data}->{$mfn};
420          }          }
421    
422          $rec ||= 0E0;          $rec ||= 0E0;
# Line 287  First record in database has position 1. Line 434  First record in database has position 1.
434    
435  sub pos {  sub pos {
436          my $self = shift;          my $self = shift;
437          return $self->{'current_mfn'};          return $self->{pos};
438  }  }
439    
440    
# Line 301  Result from this function can be used to Line 448  Result from this function can be used to
448    
449   foreach my $mfn ( 1 ... $isis->size ) { ... }   foreach my $mfn ( 1 ... $isis->size ) { ... }
450    
451  because it takes into account C<start_mfn> and C<limit_mfn>.  because it takes into account C<offset> and C<limit>.
452    
453  =cut  =cut
454    
455  sub size {  sub size {
456          my $self = shift;          my $self = shift;
457          return $self->{'size'};          return $self->{size};
458  }  }
459    
460  =head2 seek  =head2 seek
# Line 329  sub seek { Line 476  sub seek {
476          if ($pos < 1) {          if ($pos < 1) {
477                  $log->warn("seek before first record");                  $log->warn("seek before first record");
478                  $pos = 1;                  $pos = 1;
479          } elsif ($pos > $self->{'max_mfn'}) {          } elsif ($pos > $self->{max_pos}) {
480                  $log->warn("seek beyond last record");                  $log->warn("seek beyond last record");
481                  $pos = $self->{'max_mfn'};                  $pos = $self->{max_pos};
482          }          }
483    
484          return $self->{'current_mfn'} = (($pos - 1) || -1);          return $self->{pos} = (($pos - 1) || -1);
485  }  }
486    
487    =head2 stats
488    
489    Dump statistics about field and subfield usage
490    
491      print $input->stats;
492    
493    =cut
494    
495    sub stats {
496            my $self = shift;
497    
498  =head1 MEMORY USAGE          my $log = $self->_get_logger();
499    
500  C<low_mem> options is double-edged sword. If enabled, WebPAC          my $s = $self->{_stats};
501  will run on memory constraint machines (which doesn't have enough          if (! $s) {
502  physical RAM to create memory structure for whole source database).                  $log->warn("called stats, but there is no statistics collected");
503                    return;
504            }
505    
506  If your machine has 512Mb or more of RAM and database is around 10000 records,          my $max_fld = 0;
 memory shouldn't be an issue. If you don't have enough physical RAM, you  
 might consider using virtual memory (if your operating system is handling it  
 well, like on FreeBSD or Linux) instead of dropping to L<DBM::Deep> to handle  
 parsed structure of ISIS database (this is what C<low_mem> option does).  
507    
508  Hitting swap at end of reading source database is probably o.k. However,          my $out = join("\n",
509  hitting swap before 90% will dramatically decrease performance and you will                  map {
510  be better off with C<low_mem> and using rest of availble memory for                          my $f = $_ || die "no field";
511  operating system disk cache (Linux is particuallary good about this).                          my $v = $s->{fld}->{$f} || die "no s->{fld}->{$f}";
512  However, every access to database record will require disk access, so                          $max_fld = $v if ($v > $max_fld);
513  generation phase will be slower 10-100 times.  
514                            my $o = sprintf("%4s %d ~", $f, $v);
515    
516                            if (defined($s->{sf}->{$f})) {
517                                    map {
518                                            $o .= sprintf(" %s:%d%s", $_,
519                                                    $s->{sf}->{$f}->{$_}->{count},
520                                                    $s->{sf}->{$f}->{$_}->{repeatable} ? '*' : '',
521                                            );
522                                    } sort keys %{ $s->{sf}->{$f} };
523                            }
524    
525                            if (my $v_r = $s->{repeatable}->{$f}) {
526                                    $o .= " ($v_r)" if ($v_r != $v);
527                            }
528    
529  Parsed structures are essential - you just have option to trade RAM memory                          $o;
530  (which is fast) for disk space (which is slow). Be sure to have planty of                  } sort { $a cmp $b } keys %{ $s->{fld} }
531  disk space if you are using C<low_mem> and thus L<DBM::Deep>.          );
532    
533            $log->debug( sub { dump($s) } );
534    
535  However, when WebPAC is running on desktop machines (or laptops :-), it's          return $out;
536  highly undesireable for system to start swapping. Using C<low_mem> option can  }
 reduce WecPAC memory usage to around 64Mb for same database with lookup  
 fields and sorted indexes which stay in RAM. Performance will suffer, but  
 memory usage will really be minimal. It might be also more confortable to  
 run WebPAC reniced on those machines.  
537    
538    =head2 dump_ascii
539    
540    Display humanly readable dump of record
541    
542    =cut
543    
544    sub dump_ascii {
545            my $self = shift;
546    
547            return unless $self->{ll_db};
548    
549            if ($self->{ll_db}->can('dump_rec')) {
550                    return $self->{ll_db}->dump_ascii( $self->{pos} );
551            } else {
552                    return dump( $self->{ll_db}->fetch_rec( $self->{pos} ) );
553            }
554    }
555    
556    =head2 modify_record_regexps
557    
558    Generate hash with regexpes to be applied using l<filter>.
559    
560      my $regexpes = $input->modify_record_regexps(
561                    900 => { '^a' => { ' : ' => '^b' } },
562                    901 => { '*' => { '^b' => ' ; ' } },
563      );
564    
565    =cut
566    
567    sub _get_regex {
568            my ($sf,$from,$to) = @_;
569            if ($sf =~ /^\^/) {
570                    return
571                            's/\Q'. $sf .'\E([^\^]*?)\Q'. $from .'\E([^\^]*?)/'. $sf .'$1'. $to .'$2/';
572            } else {
573                    return
574                            's/\Q'. $from .'\E/'. $to .'/g';
575            }
576    }
577    
578    sub modify_record_regexps {
579            my $self = shift;
580            my $modify_record = {@_};
581    
582            my $regexpes;
583    
584            my $log = $self->_get_logger();
585    
586            foreach my $f (keys %$modify_record) {
587                    $log->debug("field: $f");
588    
589                    foreach my $sf (keys %{ $modify_record->{$f} }) {
590                            $log->debug("subfield: $sf");
591    
592                            foreach my $from (keys %{ $modify_record->{$f}->{$sf} }) {
593                                    my $to = $modify_record->{$f}->{$sf}->{$from};
594                                    #die "no field?" unless defined($to);
595                                    $log->debug("transform: |$from| -> |$to|");
596    
597                                    my $regex = _get_regex($sf,$from,$to);
598                                    push @{ $regexpes->{$f} }, $regex;
599                                    $log->debug("regex: $regex");
600                            }
601                    }
602            }
603    
604            return $regexpes;
605    }
606    
607    =head2 modify_file_regexps
608    
609    Generate hash with regexpes to be applied using l<filter> from
610    pseudo hash/yaml format for regex mappings.
611    
612    It should be obvious:
613    
614            200
615              '^a'
616                ' : ' => '^e'
617                ' = ' => '^d'
618    
619    In field I<200> find C<'^a'> and then C<' : '>, and replace it with C<'^e'>.
620    In field I<200> find C<'^a'> and then C<' = '>, and replace it with C<'^d'>.
621    
622      my $regexpes = $input->modify_file_regexps( 'conf/modify/common.pl' );
623    
624    On undef path it will just return.
625    
626    =cut
627    
628    sub modify_file_regexps {
629            my $self = shift;
630    
631            my $modify_path = shift || return;
632    
633            my $log = $self->_get_logger();
634    
635            my $regexpes;
636    
637            CORE::open(my $fh, $modify_path) || $log->logdie("can't open modify file $modify_path: $!");
638    
639            my ($f,$sf);
640    
641            while(<$fh>) {
642                    chomp;
643                    next if (/^#/ || /^\s*$/);
644    
645                    if (/^\s*(\d+)\s*$/) {
646                            $f = $1;
647                            $log->debug("field: $f");
648                            next;
649                    } elsif (/^\s*'([^']*)'\s*$/) {
650                            $sf = $1;
651                            $log->die("can't define subfiled before field in: $_") unless ($f);
652                            $log->debug("subfield: $sf");
653                    } elsif (/^\s*'([^']*)'\s*=>\s*'([^']*)'\s*$/) {
654                            my ($from,$to) = ($1, $2);
655    
656                            $log->debug("transform: |$from| -> |$to|");
657    
658                            my $regex = _get_regex($sf,$from,$to);
659                            push @{ $regexpes->{$f} }, $regex;
660                            $log->debug("regex: $regex");
661                    }
662            }
663    
664            return $regexpes;
665    }
666    
667  =head1 AUTHOR  =head1 AUTHOR
668    
# Line 375  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 670  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
670    
671  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
672    
673  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
674    
675  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
676  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.285  
changed lines
  Added in v.774
  ViewVC Help
Powered by ViewVC 1.1.26