/[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 234 by dpavlin, Tue Dec 6 19:41:17 2005 UTC revision 536 by dpavlin, Mon Jun 26 16:39:51 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 base qw/WebPAC::Common WebPAC::Normalize/;  use base qw/WebPAC::Common WebPAC::Lookup::Normalize/;
7  use File::Slurp;  use File::Slurp;
8  use YAML qw/LoadFile/;  use YAML qw/LoadFile/;
9  use Data::Dumper;  use Data::Dumper;
# Line 14  WebPAC::Lookup - simple normalisation pl Line 14  WebPAC::Lookup - simple normalisation pl
14    
15  =head1 VERSION  =head1 VERSION
16    
17  Version 0.02  Version 0.03
18    
19  =cut  =cut
20    
21  our $VERSION = '0.02';  our $VERSION = '0.03';
22    
23  =head1 SYNOPSIS  =head1 SYNOPSIS
24    
# Line 41  value in lookup. Line 41  value in lookup.
41      'val' => 'v900' },      'val' => 'v900' },
42   ];   ];
43    
 Just for a reference, lookup data is internally stored in  
 C<< $self->{'_lookup_data'} >>.  
   
44  =head1 FUNCTIONS  =head1 FUNCTIONS
45    
46  =head2 new  =head2 new
# Line 59  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 79  sub new { Line 76  sub new {
76          } else {          } else {
77                  $log->logide("unsupported lookup file $lookup_file");                  $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 but ", 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    
# Line 89  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 104  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 116  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 145  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 161  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'}) {
# Line 180  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.
# Line 207  Dobrica Pavlinusic, C<< <dpavlin@rot13.o Line 219  Dobrica Pavlinusic, C<< <dpavlin@rot13.o
219    
220  =head1 COPYRIGHT & LICENSE  =head1 COPYRIGHT & LICENSE
221    
222  Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.  Copyright 2005-2006 Dobrica Pavlinusic, All Rights Reserved.
223    
224  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
225  under the same terms as Perl itself.  under the same terms as Perl itself.
Legend:
Removed from v.234  
changed lines
  Added in v.536
  ViewVC Help
Powered by ViewVC 1.1.26