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