/[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 4 by dpavlin, Sat Jul 16 12:37:18 2005 UTC revision 30 by dpavlin, Sun Jul 24 14:20:59 2005 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 Data::Dumper;  use Data::Dumper;
9    
# Line 42  value in lookup. Line 40  value in lookup.
40      'val' => 'v900' },      'val' => 'v900' },
41   ];   ];
42    
43    Just for a reference, lookup data is internally stored in
44    C<< $self->{'_lookup_data'} >>.
45    
46  =head1 FUNCTIONS  =head1 FUNCTIONS
47    
# Line 51  Create new lookup object. Line 51  Create new lookup object.
51    
52    my $lookup = new WebPAC::Lookup(    my $lookup = new WebPAC::Lookup(
53          lookup_file => '/path/to/conf/lookup/lookup.pm',          lookup_file => '/path/to/conf/lookup/lookup.pm',
54            is_lookup_regex => 'lookup{[^\{\}]+}';
55            save_lookup_regex => 'lookup{([^\{\}]+)}';
56    );    );
57    
58  =cut  =cut
# Line 74  sub new { Line 76  sub new {
76    
77          $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", sub { Dumper( $self->{'lookup_def'} ) }) if ($self->{'lookup_def'} !~ /ARRAY/o);
78    
79            $self->{'is_lookup_regex'} ||= 'lookup{[^\{\}]+}';
80            $self->{'save_lookup_regex'} ||= 'lookup{([^\{\}]+)}';
81    
82    
83            $self->{'LOOKUP_REGEX'} = qr/$self->{'is_lookup_regex'}/;
84            $self->{'LOOKUP_REGEX_SAVE'} = qr/$self->{'save_lookup_regex'}/;
85    
86            $log->debug("regexps: ", $self->{'LOOKUP_REGEX'}, " ", $self->{'LOOKUP_REGEX_SAVE'});
87    
88          $self ? return $self : return undef;          $self ? return $self : return undef;
89  }  }
90    
# Line 81  sub new { Line 92  sub new {
92    
93  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
94    
95   $self->create_lookup($rec);   $self->add($rec);
96    
97  Returns true if this record produced lookup.  Returns true if this record produced lookup.
98    
# Line 111  sub add($) { Line 122  sub add($) {
122                                  my $key = $self->fill_in($rec,$i->{'key'}) || next;                                  my $key = $self->fill_in($rec,$i->{'key'}) || next;
123                                  my @val = $self->fill_in($rec,$i->{'val'}) || next;                                  my @val = $self->fill_in($rec,$i->{'val'}) || next;
124                                  $log->debug("stored $key = ",sub { join(" | ",@val) });                                  $log->debug("stored $key = ",sub { join(" | ",@val) });
125                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'_lookup_data'}->{$key}}, @val;
126                          }                          }
127                  } else {                  } else {
128                          my $key = $self->fill_in($rec,$i->{'key'}) || next;                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
129                          my @val = $self->fill_in($rec,$i->{'val'}) || next;                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
130                          $log->debug("stored $key = ",sub { join(" | ",@val) });                          $log->debug("stored $key = ",sub { join(" | ",@val) });
131                          push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'_lookup_data'}->{$key}}, @val;
132                  }                  }
133          }          }
134    
135          return $n;          return $n;
136  }  }
137    
138    =head2 lookup
139    
140    Perform lookups on format supplied to it.
141    
142     my $text = $lookup->lookup('[v900]');
143    
144    Lookups can be nested (like C<[d:[a:[v900]]]>).
145    
146    =cut
147    
148    sub lookup {
149            my $self = shift;
150    
151            my $log = $self->_get_logger();
152    
153            my $tmp = shift || $log->logconfess("need format");
154    
155            if ($tmp =~ $self->{'LOOKUP_REGEX'}) {
156                    my @in = ( $tmp );
157    
158                    $log->debug("lookup for: ",$tmp);
159    
160                    my @out;
161                    while (my $f = shift @in) {
162                            if ($f =~ $self->{'LOOKUP_REGEX_SAVE'}) {
163                                    my $k = $1;
164                                    if ($self->{'_lookup_data'}->{$k}) {
165                                            foreach my $nv (@{$self->{'_lookup_data'}->{$k}}) {
166                                                    my $tmp2 = $f;
167                                                    $tmp2 =~ s/lookup{$k}/$nv/g;
168                                                    push @in, $tmp2;
169                                            }
170                                    } else {
171                                            undef $f;
172                                    }
173                            } elsif ($f) {
174                                    push @out, $f;
175                            }
176                    }
177                    $log->logconfess("return is array and it's not expected!") unless wantarray;
178                    return @out;
179            } else {
180                    return $tmp;
181            }
182    }
183    
184    =head2 regex
185    
186    Returns precompiled regex for lookup format.
187    
188     if ($foo =~ $lookup->reges) { ... }
189    
190    =cut
191    
192    sub regex {
193            my $self = shift;
194    
195            return $self->{'LOOKUP_REGEX'};
196    }
197    
198  =head1 AUTHOR  =head1 AUTHOR
199    
200  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
Legend:
Removed from v.4  
changed lines
  Added in v.30
  ViewVC Help
Powered by ViewVC 1.1.26