/[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 363 by dpavlin, Wed Jun 16 20:05:19 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    use XML::Simple;
7    
8    use Data::Dumper;
9    
10  =head1 NAME  =head1 NAME
11    
12  WebPac - base class for WebPac  WebPAC - base class for WebPAC
13    
14  =head1 DESCRIPTION  =head1 DESCRIPTION
15    
16  This class does basic thing for WebPac.  This module implements methods used by WebPAC.
17    
18  =head1 METHODS  =head1 METHODS
19    
20  =head2 new  =head2 new
21    
22  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>.
23    
24   my $webpac = new WebPac(   my $webpac = new WebPAC(
25          config_file => 'name.conf',          config_file => 'name.conf',
26          [code_page => 'ISO-8859-2',]          [code_page => 'ISO-8859-2',]
27   );   );
28    
29  Default C<code_page> is C<ISO-8859-2>.  Default C<code_page> is C<ISO-8859-2>.
30    
31    It will also read configuration files
32    C<global.conf> (used by indexer and Web font-end)
33    and configuration file specified by C<config_file>
34    which describes databases to be indexed.
35    
36  =cut  =cut
37    
38    # mapping between data type and tag which specify
39    # format in XML file
40    my %type2tag = (
41            'isis' => 'isis',
42    #       'excel' => 'column',
43    #       'marc' => 'marc',
44    #       'feed' => 'feed'
45    );
46    
47  sub new {  sub new {
48          my $class = shift;          my $class = shift;
49          my $self = {@_};          my $self = {@_};
# Line 34  sub new { Line 53  sub new {
53          # output codepage          # output codepage
54          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});          $self->{'code_page'} = 'ISO-8859-2' if (! $self->{'code_page'});
55    
56          return $self;          #
57  }          # read global.conf
58            #
 =head2 read_global_config  
   
 Read global configuration (used by indexer and Web font-end)  
   
 =cut  
   
 sub read_global_config {  
         my $self = shift;  
59    
60          $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'";
61    
# Line 60  sub read_global_config { Line 71  sub read_global_config {
71                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);                  $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);
72          }          }
73    
74          return $self;          #
75  }          # read indexer config file
76            #
 =head2 read_indexer_config  
   
 Read indexer configuration (specify databases, types etc.)  
   
 =cut  
   
 sub read_indexer_config {  
         my $self = shift;  
77    
78          $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}'";
79    
         # read global config parametars  
         foreach my $var (qw(  
                         dbi_dbd  
                         dbi_dsn  
                         dbi_user  
                         dbi_passwd  
                         show_progress  
                         my_unac_filter  
                 )) {  
                 $self->{global_config}->{$var} = $self->{global_config_file}->val('global', $var);  
         }  
   
80          return $self;          return $self;
81  }  }
82    
# 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
126          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});          my $cp = Text::Iconv->new($code_page,$self->{'code_page'});
127    
128            print STDERR "reading ISIS database '",$arg->{'filename'},"'\n" if ($self->{'debug'});
129    
130          my $isis_db = OpenIsis::open($arg->{'filename'});          my $isis_db = OpenIsis::open($arg->{'filename'});
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            print STDERR "processing $maxmfn records...\n" if ($self->{'debug'});
137    
138          # read database          # read database
139          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {          for (my $mfn = 1; $mfn <= $maxmfn; $mfn++) {
140    
# Line 163  sub open_isis { Line 162  sub open_isis {
162                  }                  }
163    
164                  # create lookup                  # create lookup
165                    my $rec = $self->{'data'}->{$mfn};
166                    $self->create_lookup($rec, @{$arg->{'lookup'}});
167    
                 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;  
                                 }  
                         }  
                 }  
168          }          }
169    
170            $self->{'current_mfn'} = 1;
171    
172          # store max mfn and return it.          # store max mfn and return it.
173          return $self->{'max_mfn'} = $maxmfn;          return $self->{'max_mfn'} = $maxmfn;
174  }  }
175    
176    =head2 fetch_rec
177    
178    Fetch next record from database. It will also display progress bar (once
179    it's implemented, that is).
180    
181     my $rec = $webpac->fetch_rec;
182    
183    =cut
184    
185    sub fetch_rec {
186            my $self = shift;
187    
188            my $mfn = $self->{'current_mfn'}++ || confess "it seems that you didn't load database!";
189    
190            if ($mfn > $self->{'max_mfn'}) {
191                    $self->{'current_mfn'} = $self->{'max_mfn'};
192                    return;
193            }
194    
195            return $self->{'data'}->{$mfn};
196    }
197    
198    =head2 open_import_xml
199    
200    Read file from C<import_xml/> directory and parse it.
201    
202     $webpac->open_import_xml(type => 'isis');
203    
204    =cut
205    
206    sub open_import_xml {
207            my $self = shift;
208    
209            my $arg = {@_};
210            confess "need type to load file from import_xml/" if (! $arg->{'type'});
211    
212            my $type = $arg->{'type'};
213    
214            my $type_base = $type;
215            $type_base =~ s/_.*$//g;
216    
217            my $f = "./import_xml/$type.xml";
218            confess "import_xml file '$f' doesn't exist!" if (! -e "$f");
219    
220            print STDERR "reading '$f'\n" if ($self->{'debug'});
221    
222            $self->{'import_xml'} = XMLin($f,
223                    ForceArray => [ $type2tag{$type_base}, 'config', 'format' ],
224                    ForceContent => 1
225            );
226    
227            print Dumper($self->{'import_xml'});
228    
229    }
230    
231    =head2 create_lookup
232    
233    Create lookup from record using lookup definition.
234    
235    =cut
236    
237    sub create_lookup {
238            my $self = shift;
239    
240            my $rec = shift || confess "need record to create lookup";
241            confess("need HASH as first argument!") if ($rec !~ /HASH/o);
242    
243            foreach my $i (@_) {
244                    if ($i->{'eval'}) {
245                            my $eval = $self->fill_in($rec,$i->{'eval'});
246                            my $key = $self->fill_in($rec,$i->{'key'});
247                            my @val = $self->fill_in($rec,$i->{'val'});
248                            if ($key && @val && eval $eval) {
249                                    push @{$self->{'lookup'}->{$key}}, @val;
250                            }
251                    } else {
252                            my $key = $self->fill_in($rec,$i->{'key'});
253                            my @val = $self->fill_in($rec,$i->{'val'});
254                            if ($key && @val) {
255                                    push @{$self->{'lookup'}->{$key}}, @val;
256                            }
257                    }
258            }
259    }
260    
261    =head2 get_data
262    
263    Returns value from record.
264    
265     $self->get_data(\$rec,$f,$sf,$i,\$found);
266    
267    Arguments are:
268    record reference C<$rec>,
269    field C<$f>,
270    optional subfiled C<$sf>,
271    index for repeatable values C<$i>.
272    
273    Optinal variable C<$found> will be incremeted if thre
274    is field.
275    
276    Returns value or empty string.
277    
278    =cut
279    
280    sub get_data {
281            my $self = shift;
282    
283            my ($rec,$f,$sf,$i,$found) = @_;
284            if ($$rec->{$f}) {
285                    if ($sf && $$rec->{$f}->[$i]->{$sf}) {
286                            $$found++ if (defined($$found));
287                            return $$rec->{$f}->[$i]->{$sf};
288                    } elsif ($$rec->{$f}->[$i]) {
289                            $$found++ if (defined($$found));
290                            return $$rec->{$f}->[$i];
291                    }
292            } else {
293                    return '';
294            }
295    }
296    
297  =head2 fill_in  =head2 fill_in
298    
299  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 303  values from record.
303   $webpac->fill_in($rec,'v250^a');   $webpac->fill_in($rec,'v250^a');
304    
305  Optional argument is ordinal number for repeatable fields. By default,  Optional argument is ordinal number for repeatable fields. By default,
306  it's assume to be first repeatable field.  it's assume to be first repeatable field (fields are perl array, so first
307    element is 0).
308    Following example will read second value from repeatable field.
309    
310     $webpac->fill_in($rec,'Title: v250^a',1);
311    
312    This function B<does not> perform parsing of format to inteligenty skip
313    delimiters before fields which aren't used.
314    
315  =cut  =cut
316    
# Line 209  sub fill_in { Line 323  sub fill_in {
323          my $i = shift || 0;          my $i = shift || 0;
324    
325          # FIXME remove for speedup?          # FIXME remove for speedup?
326          if ($rec !~ /HASH/) {          confess("need HASH as first argument!") if ($rec !~ /HASH/o);
                 confess("need HASH as first argument!");  
         }  
327    
328          my $found = 0;          my $found = 0;
329    
330          # get field with subfield          my $eval_code;
331          sub get_sf {          # remove eval{...} from beginning
332                  my ($found,$rec,$f,$sf,$i) = @_;          $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
                 if ($$rec->{$f} && $$rec->{$f}->[$i]->{$sf}) {  
                         $$found++;  
                         return $$rec->{$f}->[$i]->{$sf};  
                 } else {  
                         return '';  
                 }  
         }  
   
         # get field (without subfield)  
         sub get_nosf {  
                 my ($found,$rec,$f,$i) = @_;  
                 if ($$rec->{$f} && $$rec->{$f}->[$i]) {  
                         $$found++;  
                         return $$rec->{$f}->[$i];  
                 } else {  
                         return '';  
                 }  
         }  
333    
334          # do actual replacement of placeholders          # do actual replacement of placeholders
335          $format =~ s/v(\d+)\^(\w)/get_sf(\$found,\$rec,$1,$2,$i)/ges;          $format =~ s/v(\d+)(?:\^(\w))*/$self->get_data(\$rec,$1,$2,$i,\$found)/ges;
         $format =~ s/v(\d+)/get_nosf(\$found,\$rec,$1,$i)/ges;  
336    
337          if ($found) {            if ($found) {
338                  return $format;                  if ($eval_code) {
339                            my $eval = $self->fill_in($rec,$eval_code,$i);
340                            return if (! eval $eval);
341                    }
342                    # do we have lookups?
343                    if ($format =~ /\[[^\[\]]+\]/o) {
344                            return $self->lookup($format);
345                    } else {
346                            return $format;
347                    }
348          } else {          } else {
349                  return;                  return;
350          }          }
# Line 250  sub fill_in { Line 352  sub fill_in {
352    
353  =head2 lookup  =head2 lookup
354    
355  This function will perform lookups on format supplied to it.  Perform lookups on format supplied to it.
356    
357   my $txt = $self->lookup('[v900]');   my $txt = $self->lookup('[v900]');
358    
359    Lookups can be nested (like C<[d:[a:[v900]]]>).
360    
361  =cut  =cut
362    
363  sub lookup {  sub lookup {
# Line 261  sub lookup { Line 365  sub lookup {
365    
366          my $tmp = shift || confess "need format";          my $tmp = shift || confess "need format";
367    
368          if ($tmp =~ /\[[^\[\]]+\]/) {          if ($tmp =~ /\[[^\[\]]+\]/o) {
369                  my @in = ( $tmp );                  my @in = ( $tmp );
370  print "##lookup $tmp\n";  #print "##lookup $tmp\n";
371                  my @out;                  my @out;
372                  while (my $f = shift @in) {                  while (my $f = shift @in) {
373                          if ($f =~ /\[([^\[\]]+)\]/) {                          if ($f =~ /\[([^\[\]]+)\]/) {
374                                  my $k = $1;                                  my $k = $1;
375                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'lookup'}->{$k}) {
376  print "## lookup key = $k\n";  #print "## lookup key = $k\n";
377                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {
378                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
379                                                  $tmp2 =~ s/\[$k\]/$nv/g;                                                  $tmp2 =~ s/\[$k\]/$nv/g;
380                                                  push @in, $tmp2;                                                  push @in, $tmp2;
381  print "## lookup in => $tmp2\n";  #print "## lookup in => $tmp2\n";
382                                          }                                          }
383                                  } else {                                  } else {
384                                          undef $f;                                          undef $f;
385                                  }                                  }
386                          } elsif ($f) {                          } elsif ($f) {
387                                  push @out, $f;                                  push @out, $f;
388  print "## lookup out => $f\n";  #print "## lookup out => $f\n";
389                          }                          }
390                  }                  }
391                  return @out;                  return @out;
# Line 290  print "## lookup out => $f\n"; Line 394  print "## lookup out => $f\n";
394          }          }
395  }  }
396    
397    =head2 parse
398    
399    Perform smart parsing of string, skipping delimiters for fields which aren't
400    defined. It can also eval code in format starting with C<eval{...}> and
401    return output or nothing depending on eval code.
402    
403     $webpac->parse($rec,'eval{"v901^a" eq "Deskriptor"}descriptor: v250^a', $i);
404    
405    =cut
406    
407    sub parse {
408            my $self = shift;
409    
410            my ($rec, $format, $i) = @_;
411    
412            confess("need HASH as first argument!") if ($rec !~ /HASH/o);
413    
414            $i = 0 if (! $i);
415    
416            my @out;
417    
418            my $eval_code;
419            # remove eval{...} from beginning
420            $eval_code = $1 if ($format =~ s/^eval{([^}]+)}//s);
421    
422            my $prefix;
423            my $all_found=0;
424    
425    #print "## $format\n";
426            while ($format =~ s/^(.*?)v(\d+)(?:\^(\w))*//s) {
427    #print "## [ $1 | $2 | $3 ] $format\n";
428    
429                    my $del = $1 || '';
430                    $prefix ||= $del if ($all_found == 0);
431    
432                    my $found = 0;
433                    my $tmp = $self->get_data(\$rec,$2,$3,$i,\$found);
434    
435                    if ($found) {
436                            push @out, $del;
437                            push @out, $tmp;
438                            $all_found += $found;
439                    }
440            }
441    
442            return if (! $all_found);
443    
444            my $out = join('',@out) . $format;
445    
446            # add prefix if not there
447            $out = $prefix . $out if ($out !~ m/^\Q$prefix\E/);
448            
449            if ($eval_code) {
450                    my $eval = $self->fill_in($rec,$eval_code,$i);
451                    return if (! eval $eval);
452            }
453    
454            return $out;
455    }
456    
457  1;  1;
Legend:
Removed from v.352  
changed lines
  Added in v.363
  ViewVC Help
Powered by ViewVC 1.1.26