/[webpac]/trunk2/lib/WebPAC.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 /trunk2/lib/WebPAC.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 352 by dpavlin, Tue Jun 15 22:40:07 2004 UTC revision 358 by dpavlin, Wed Jun 16 14:31:33 2004 UTC
# Line 1  Line 1 
1  package WebPac;  package WebPAC;
2    
3  use Carp;  use Carp;
4    use Text::Iconv;
5    use Config::IniFiles;
6    
7    use Data::Dumper;
8    
9  =head1 NAME  =head1 NAME
10    
11  WebPac - base class for WebPac  WebPAC - base class for WebPAC
12    
13  =head1 DESCRIPTION  =head1 DESCRIPTION
14    
15  This class does basic thing for WebPac.  This module implements methods used by WebPAC.
16    
17  =head1 METHODS  =head1 METHODS
18    
19  =head2 new  =head2 new
20    
21  This will create new instance of WebPac using configuration specified by C<config_file>.  This will create new instance of WebPAC using configuration specified by C<config_file>.
22    
23   my $webpac = new WebPac(   my $webpac = new WebPAC(
24          config_file => 'name.conf',          config_file => 'name.conf',
25          [code_page => 'ISO-8859-2',]          [code_page => 'ISO-8859-2',]
26   );   );
27    
28  Default C<code_page> is C<ISO-8859-2>.  Default C<code_page> is C<ISO-8859-2>.
29    
30    It will also read configuration files
31    C<global.conf> (used by indexer and Web font-end)
32    and configuration file specified by C<config_file>
33    which describes databases to be indexed.
34    
35  =cut  =cut
36    
37  sub new {  sub new {
# Line 34  sub new { Line 43  sub new {
43          # output codepage          # output codepage
44          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});
45    
46          return $self;          #
47  }          # read global.conf
48            #
 =head2 read_global_config  
   
 Read global configuration (used by indexer and Web font-end)  
   
 =cut  
   
 sub read_global_config {  
         my $self = shift;  
49    
50          $self->{global_config_file} = new Config::IniFiles( -file => 'global.conf' ) || croak "can't open 'global.conf'";          $self->{global_config_file} = new Config::IniFiles( -file => 'global.conf' ) || croak "can't open 'global.conf'";
51    
# Line 60  sub read_global_config { Line 61  sub read_global_config {
61                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);
62          }          }
63    
64          return $self;          #
65  }          # read indexer config file
66            #
 =head2 read_indexer_config  
   
 Read indexer configuration (specify databases, types etc.)  
   
 =cut  
   
 sub read_indexer_config {  
         my $self = shift;  
67    
68          $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || croak "can't open '$self->{config_file}'";          $self->{indexer_config_file} = new Config::IniFiles( -file => $self->{config_file} ) || croak "can't open '$self->{config_file}'";
69    
# Line 102  Open CDS/ISIS database using OpenIsis mo Line 95  Open CDS/ISIS database using OpenIsis mo
95    
96  By default, ISIS code page is assumed to be C<852>.  By default, ISIS code page is assumed to be C<852>.
97    
98  If C<limit_mfn> is set, it will read just 500 records from  If optional parametar C<limit_mfn> is set, it will read just 500 records
99  database in example above.  from database in example above.
100    
101  Returns number of last record read into memory (size of database, really).  Returns number of last record read into memory (size of database, really).
102    
# Line 127  sub open_isis { Line 120  sub open_isis {
120          croak "need filename" if (! $arg->{'filename'});          croak "need filename" if (! $arg->{'filename'});
121          my $code_page = $arg->{'code_page'} || '852';          my $code_page = $arg->{'code_page'} || '852';
122    
123            use OpenIsis;
124    
125          #$self->{'isis_code_page'} = $code_page;          #$self->{'isis_code_page'} = $code_page;
126    
127          # create Text::Iconv object          # create Text::Iconv object
# Line 136  sub open_isis { Line 131  sub open_isis {
131    
132          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;          my $maxmfn = OpenIsis::maxRowid( $isis_db ) || 1;
133    
134            $maxmfn = $self->{limit_mfn} if ($self->{limit_mfn});
135    
136          # read database          # read database
137          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {
138    
# Line 163  sub open_isis { Line 160  sub open_isis {
160                  }                  }
161    
162                  # create lookup                  # create lookup
163                    my $rec = $self->{'data'}->{$mfn};
164                    $self->create_lookup($rec, @{$arg->{'lookup'}});
165    
                 foreach my $i (@{$arg->{lookup}}) {  
                         my $rec = $self->{'data'}->{$mfn};  
                         if ($i->{'eval'}) {  
                                 my $eval = $self->fill_in($rec,$i->{'eval'});  
                                 my $key = $self->fill_in($rec,$i->{'key'});  
                                 my @val = $self->fill_in($rec,$i->{'val'});  
                                 if ($key && @val && eval $eval) {  
                                         push @{$self->{'lookup'}->{$key}}, @val;  
                                 }  
                         } else {  
                                 my $key = $self->fill_in($rec,$i->{'key'});  
                                 my @val = $self->fill_in($rec,$i->{'val'});  
                                 if ($key && @val) {  
                                         push @{$self->{'lookup'}->{$key}}, @val;  
                                 }  
                         }  
                 }  
166          }          }
167    
168          # store max mfn and return it.          # store max mfn and return it.
169          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
170  }  }
171    
172    =head2 create_lookup
173    
174    Create lookup from record using lookup definition.
175    
176    =cut
177    
178    sub create_lookup {
179            my $self = shift;
180    
181            my $rec = shift || confess "need record to create lookup";
182            confess("need HASH as first argument!") if ($rec !~ /HASH/o);
183    
184            foreach my $i (@_) {
185                    if ($i->{'eval'}) {
186                            my $eval = $self->fill_in($rec,$i->{'eval'});
187                            my $key = $self->fill_in($rec,$i->{'key'});
188                            my @val = $self->fill_in($rec,$i->{'val'});
189                            if ($key && @val && eval $eval) {
190                                    push @{$self->{'lookup'}->{$key}}, @val;
191                            }
192                    } else {
193                            my $key = $self->fill_in($rec,$i->{'key'});
194                            my @val = $self->fill_in($rec,$i->{'val'});
195                            if ($key && @val) {
196                                    push @{$self->{'lookup'}->{$key}}, @val;
197                            }
198                    }
199            }
200    }
201    
202    =head2 get_data
203    
204    Returns value from record.
205    
206     $self->get_data(\$rec,$f,$sf,$i,\$found);
207    
208    Arguments are:
209    record reference C<$rec>,
210    field C<$f>,
211    optional subfiled C<$sf>,
212    index for repeatable values C<$i>.
213    
214    Optinal variable C<$found> will be incremeted if thre
215    is field.
216    
217    Returns value or empty string.
218    
219    =cut
220    
221    sub get_data {
222            my $self = shift;
223    
224            my ($rec,$f,$sf,$i,$found) = @_;
225            if ($$rec->{$f}) {
226                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
227                            $$found++ if (defined($$found));
228                            return $$rec->{$f}->[$i]->{$sf};
229                    } elsif ($$rec->{$f}->[$i]) {
230                            $$found++ if (defined($$found));
231                            return $$rec->{$f}->[$i];
232                    }
233            } else {
234                    return '';
235            }
236    }
237    
238  =head2 fill_in  =head2 fill_in
239    
240  Workhourse of all: takes record from in-memory structure of database and  Workhourse of all: takes record from in-memory structure of database and
# Line 196  values from record. Line 244  values from record.
244   $webpac->fill_in($rec,'v250^a');   $webpac->fill_in($rec,'v250^a');
245    
246  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
247  it's assume to be first repeatable field.  it's assume to be first repeatable field (fields are perl array, so first
248    element is 0).
249    Following example will read second value from repeatable field.
250    
251     $webpac->fill_in($rec,'Title: v250^a',1);
252    
253    This function B<does not> perform parsing of format to inteligenty skip
254    delimiters before fields which aren't used.
255    
256  =cut  =cut
257    
# Line 209  sub fill_in { Line 264  sub fill_in {
264          my $i = shift || 0;          my $i = shift || 0;
265    
266          # FIXME remove for speedup?          # FIXME remove for speedup?
267          if ($rec !~ /HASH/) {          confess("need HASH as first argument!") if ($rec !~ /HASH/o);
                 confess("need HASH as first argument!");  
         }  
268    
269          my $found = 0;          my $found = 0;
270    
271          # get field with subfield          # do actual replacement of placeholders
272          sub get_sf {          $format =~ s/v(\d+)(?:\^(\w))*/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
                 my ($found,$rec,$f,$sf,$i) = @_;  
                 if ($$rec->{$f} && $$rec->{$f}->[$i]->{$sf}) {  
                         $$found++;  
                         return $$rec->{$f}->[$i]->{$sf};  
                 } else {  
                         return '';  
                 }  
         }  
273    
274          # get field (without subfield)          if ($found) {
275          sub get_nosf {                  # do we have lookups?
276                  my ($found,$rec,$f,$i) = @_;                  if ($format =~ /\[[^\[\]]+\]/o) {
277                  if ($$rec->{$f} && $$rec->{$f}->[$i]) {                          return $self->lookup($format);
                         $$found++;  
                         return $$rec->{$f}->[$i];  
278                  } else {                  } else {
279                          return '';                          return $format;
280                  }                  }
         }  
   
         # do actual replacement of placeholders  
         $format =~ s/v(\d+)\^(\w)/get_sf(\$found,\$rec,$1,$2,$i)/ges;  
         $format =~ s/v(\d+)/get_nosf(\$found,\$rec,$1,$i)/ges;  
   
         if ($found) {    
                 return $format;  
281          } else {          } else {
282                  return;                  return;
283          }          }
# Line 250  sub fill_in { Line 285  sub fill_in {
285    
286  =head2 lookup  =head2 lookup
287    
288  This function will perform lookups on format supplied to it.  Perform lookups on format supplied to it.
289    
290   my $txt = $self->lookup('[v900]');   my $txt = $self->lookup('[v900]');
291    
292    Lookups can be nested (like C<[d:[a:[v900]]]>).
293    
294  =cut  =cut
295    
296  sub lookup {  sub lookup {
# Line 261  sub lookup { Line 298  sub lookup {
298    
299          my $tmp = shift || confess "need format";          my $tmp = shift || confess "need format";
300    
301          if ($tmp =~ /\[[^\[\]]+\]/) {          if ($tmp =~ /\[[^\[\]]+\]/o) {
302                  my @in = ( $tmp );                  my @in = ( $tmp );
303  print "##lookup $tmp\n";  #print "##lookup $tmp\n";
304                  my @out;                  my @out;
305                  while (my $f = shift @in) {                  while (my $f = shift @in) {
306                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /\[([^\[\]]+)\]/) {
307                                  my $k = $1;                                  my $k = $1;
308                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
309  print "## lookup key = $k\n";  #print "## lookup key = $k\n";
310                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
311                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
312                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/\[$k\]/$nv/g;
313                                                  push @in, $tmp2;                                                  push @in, $tmp2;
314  print "## lookup in => $tmp2\n";  #print "## lookup in => $tmp2\n";
315                                          }                                          }
316                                  } else {                                  } else {
317                                          undef $f;                                          undef $f;
318                                  }                                  }
319                          } elsif ($f) {                          } elsif ($f) {
320                                  push @out, $f;                                  push @out, $f;
321  print "## lookup out => $f\n";  #print "## lookup out => $f\n";
322                          }                          }
323                  }                  }
324                  return @out;                  return @out;
# Line 290  print "## lookup out => $f\n"; Line 327  print "## lookup out => $f\n";
327          }          }
328  }  }
329    
330    =head2 parse
331    
332    Perform smart parsing of string, skipping delimiters for fields which aren't
333    defined. It can also eval code in format starting with C<eval{...}> and
334    return output or nothing depending on eval code.
335    
336     $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
337    
338    =cut
339    
340    sub parse {
341            my $self = shift;
342    
343            my ($rec, $format, $i) = @_;
344    
345            confess("need HASH as first argument!") if ($rec !~ /HASH/o);
346    
347            $i = 0 if (! $i);
348    
349            my @out;
350    
351            my $eval_code;
352            # remove eval{...} from beginning
353            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
354    
355            my $prefix;
356            my $all_found=0;
357    
358    print "## $format\n";
359            while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {
360    print "## [ $1 | $2 | $3 ] $format\n";
361    
362                    my $del = $1 || '';
363                    $prefix ||= $del;
364    
365                    my $found = 0;
366                    my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);
367    
368                    if ($found) {
369                            push @out, $del;
370                            push @out, $tmp;
371                            $all_found += $found;
372                    }
373            }
374    
375            return if (! $all_found);
376    
377            print Dumper($prefix, \@out);
378    
379            my $out = join('',@out) . $format;
380    
381            # add prefix if not there
382            $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
383            
384            return $out;
385    }
386    
387  1;  1;
Legend:
Removed from v.352  
changed lines
  Added in v.358
  ViewVC Help
Powered by ViewVC 1.1.26