/[webpac2]/trunk/lib/WebPAC/Lookup.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/Lookup.pm

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

revision 12 by dpavlin, Sat Jul 16 22:57:26 2005 UTC revision 473 by dpavlin, Sat May 13 12:07:56 2006 UTC
# Line 3  package WebPAC::Lookup; Line 3  package WebPAC::Lookup;
3  use warnings;  use warnings;
4  use strict;  use strict;
5    
6  use WebPAC::Common;  use base qw/WebPAC::Common WebPAC::Normalize/;
   
 use base qw/WebPAC::Common/;  
7  use File::Slurp;  use File::Slurp;
8    use YAML qw/LoadFile/;
9  use Data::Dumper;  use Data::Dumper;
10    
11  =head1 NAME  =head1 NAME
# Line 15  WebPAC::Lookup - simple normalisation pl Line 14  WebPAC::Lookup - simple normalisation pl
14    
15  =head1 VERSION  =head1 VERSION
16    
17  Version 0.01  Version 0.03
18    
19  =cut  =cut
20    
21  our $VERSION = '0.01';  our $VERSION = '0.03';
22    
23  =head1 SYNOPSIS  =head1 SYNOPSIS
24    
# Line 42  value in lookup. Line 41  value in lookup.
41      'val' => 'v900' },      'val' => 'v900' },
42   ];   ];
43    
   
44  =head1 FUNCTIONS  =head1 FUNCTIONS
45    
46  =head2 new  =head2 new
# Line 58  Create new lookup object. Line 56  Create new lookup object.
56  =cut  =cut
57    
58  sub new {  sub new {
59          my $class = shift;          my $class = shift;
60          my $self = {@_};          my $self = {@_};
61          bless($self, $class);          bless($self, $class);
62    
63          my $log = $self->_get_logger();          my $log = $self->_get_logger();
# Line 68  sub new { Line 66  sub new {
66    
67          my $lookup_code = read_file($lookup_file) || $log->logconfess("can't read lookup file $lookup_file: $!");          my $lookup_code = read_file($lookup_file) || $log->logconfess("can't read lookup file $lookup_file: $!");
68    
69          {          if ($lookup_file =~ m#\.pm$#) {
70                  no strict 'vars';                  no strict 'vars';
71                  do $lookup_file or $log->logdie("Failed to read configuration parameters '$lookup_file' $! $@");                  do $lookup_file or $log->logdie("Failed to read configuration parameters '$lookup_file' $! $@");
72                  $self->{'lookup_def'} = \@lookup || $log->logdie("lookup config $lookup_file doesn't produce \@lookup array");                  $self->{'lookup_def'} = \@lookup || $log->logdie("lookup config $lookup_file doesn't produce \@lookup array");
73            } elsif ($lookup_file =~ m#\.(:?yml|yaml)$#) {
74                    my $yaml = LoadFile( $lookup_file ) || $log->logdie("lookup YAML file $lookup_file error: $!");
75                    $self->{'lookup_def'} = $yaml->{lookup} || $log->logdie("lookup YAML file $lookup_file should begin with 'lookup:'");
76            } else {
77                    $log->logide("unsupported lookup file $lookup_file");
78          }          }
79            $log->debug("lookup_def: " . Dumper( $self->{lookup_def} ));
80    
81          $log->logconfess("lookup config file isn't ARRAY", sub { Dumper( $self->{'lookup_def'} ) }) if ($self->{'lookup_def'} !~ /ARRAY/o);          $log->logconfess("lookup config file isn't ARRAY but ", sub { Dumper( $self->{'lookup_def'} ) }) if ($self->{'lookup_def'} !~ /ARRAY/o);
82    
83          $self->{'is_lookup_regex'} ||= 'lookup{[^\{\}]+}';          $self->{'is_lookup_regex'} ||= 'lookup{[^\{\}]+}';
84          $self->{'save_lookup_regex'} ||= 'lookup{([^\{\}]+)}';          $self->{'save_lookup_regex'} ||= 'lookup{([^\{\}]+)}';
# Line 83  sub new { Line 87  sub new {
87          $self->{'LOOKUP_REGEX'} = qr/$self->{'is_lookup_regex'}/;          $self->{'LOOKUP_REGEX'} = qr/$self->{'is_lookup_regex'}/;
88          $self->{'LOOKUP_REGEX_SAVE'} = qr/$self->{'save_lookup_regex'}/;          $self->{'LOOKUP_REGEX_SAVE'} = qr/$self->{'save_lookup_regex'}/;
89    
90          $log->debug("regexps: ", $self->{'LOOKUP_REGEX'}, " ", $self->{'LOOKUP_REGEX_SAVE'});          $log->debug("regexps lookup:", $self->{'LOOKUP_REGEX'}, " save:", $self->{'LOOKUP_REGEX_SAVE'});
91    
92          $self ? return $self : return undef;          $self ? return $self : return undef;
93  }  }
# Line 98  Returns true if this record produced loo Line 102  Returns true if this record produced loo
102    
103  =cut  =cut
104    
105  sub add($) {  sub add {
106          my $self = shift;          my $self = shift;
107    
108          my $log = $self->_get_logger();          my $log = $self->_get_logger();
# Line 110  sub add($) { Line 114  sub add($) {
114          my $n = 0;          my $n = 0;
115    
116          foreach my $i (@{ $self->{'lookup_def'} }) {          foreach my $i (@{ $self->{'lookup_def'} }) {
117                  $log->logconfess("need key") unless defined($i->{'key'});                  $log->logconfess("need key in ", Dumper($i) ) unless defined($i->{'key'});
118                  $log->logconfess("need val") unless defined($i->{'val'});                  $log->logconfess("need val in ", Dumper($i) ) unless defined($i->{'val'});
119    
120                  $n++;                  $n++;
121    
# Line 122  sub add($) { Line 126  sub add($) {
126                                  my $key = $self->fill_in($rec,$i->{'key'}) || next;                                  my $key = $self->fill_in($rec,$i->{'key'}) || next;
127                                  my @val = $self->fill_in($rec,$i->{'val'}) || next;                                  my @val = $self->fill_in($rec,$i->{'val'}) || next;
128                                  $log->debug("stored $key = ",sub { join(" | ",@val) });                                  $log->debug("stored $key = ",sub { join(" | ",@val) });
129                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'_lookup_data'}->{$key}}, @val;
130                          }                          }
131                  } else {                  } else {
132                          my $key = $self->fill_in($rec,$i->{'key'}) || next;                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
133                          my @val = $self->fill_in($rec,$i->{'val'}) || next;                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
134                          $log->debug("stored $key = ",sub { join(" | ",@val) });                          $log->debug("stored $key = ",sub { join(" | ",@val) });
135                          push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'_lookup_data'}->{$key}}, @val;
136                  }                  }
137          }          }
138    
# Line 139  sub add($) { Line 143  sub add($) {
143    
144  Perform lookups on format supplied to it.  Perform lookups on format supplied to it.
145    
146   my $text = $lookup->lookup('[v900]');   my $text = $lookup->lookup('lookup{v900}');
147    
148  Lookups can be nested (like C<[d:[a:[v900]]]>).  Lookups can be nested (like lookup{B<d:>lookup{B<a:>lookup{B<v900>}}}).
149    
150  =cut  =cut
151    
# Line 155  sub lookup { Line 159  sub lookup {
159          if ($tmp =~ $self->{'LOOKUP_REGEX'}) {          if ($tmp =~ $self->{'LOOKUP_REGEX'}) {
160                  my @in = ( $tmp );                  my @in = ( $tmp );
161    
                 $log->debug("lookup for: ",$tmp);  
   
162                  my @out;                  my @out;
163                  while (my $f = shift @in) {                  while (my $f = shift @in) {
164                          if ($f =~ $self->{'LOOKUP_REGEX_SAVE'}) {                          if ($f =~ $self->{'LOOKUP_REGEX_SAVE'}) {
165                                  my $k = $1;                                  my $k = $1;
166                                  if ($self->{'lookup'}->{$k}) {                                  if ($self->{'_lookup_data'}->{$k}) {
167                                          foreach my $nv (@{$self->{'lookup'}->{$k}}) {                                          foreach my $nv (@{$self->{'_lookup_data'}->{$k}}) {
168                                                  my $tmp2 = $f;                                                  my $tmp2 = $f;
169                                                  $tmp2 =~ s/lookup{$k}/$nv/g;                                                  $tmp2 =~ s/lookup{$k}/$nv/g;
170                                                  push @in, $tmp2;                                                  push @in, $tmp2;
# Line 174  sub lookup { Line 176  sub lookup {
176                                  push @out, $f;                                  push @out, $f;
177                          }                          }
178                  }                  }
179                    $log->debug("lookup for: ",$tmp, " returned: ", join(", ",@out));
180    
181                  $log->logconfess("return is array and it's not expected!") unless wantarray;                  $log->logconfess("return is array and it's not expected!") unless wantarray;
182    
183                  return @out;                  return @out;
184          } else {          } else {
185                  return $tmp;                  return $tmp;
186          }          }
187  }  }
188    
189    =head2 lookup_hash
190    
191    Returns hash representation of lookup data
192    
193      my $l_hash = $lookup->lookup_hash;
194    
195    =cut
196    
197    sub lookup_hash {
198            my $self = shift;
199            return $self->{_lookup_data};
200    }
201    
202  =head2 regex  =head2 regex
203    
204  Returns precompiled regex for lookup format.  Returns precompiled regex for lookup format.
Legend:
Removed from v.12  
changed lines
  Added in v.473
  ViewVC Help
Powered by ViewVC 1.1.26