/[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

trunk/lib/WebPAC/Normalize/Lookup.pm revision 3 by dpavlin, Sat Jul 16 11:07:38 2005 UTC trunk/lib/WebPAC/Lookup.pm revision 330 by dpavlin, Tue Dec 27 22:26:43 2005 UTC
# Line 1  Line 1 
1  package WebPAC::Normalize::Lookup;  package WebPAC::Lookup;
2    
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;
10    
11  =head1 NAME  =head1 NAME
12    
13  WebPAC::Normalize::Lookup - simple normalisation plugin to produce lookup  WebPAC::Lookup - simple normalisation plugin to produce lookup
14    
15  =head1 VERSION  =head1 VERSION
16    
17  Version 0.01  Version 0.02
18    
19  =cut  =cut
20    
21  our $VERSION = '0.01';  our $VERSION = '0.02';
22    
23  =head1 SYNOPSIS  =head1 SYNOPSIS
24    
25  This module will produce in-memory lookups for easy resolution of lookups  This module will produce in-memory lookups for easy resolution of lookups
26  to different records in source files. It can also be use with  to different records in source files. This will enable you to resolve
27  C<WebPAC::Normalize::Tree> to produce tree hierarchies.  relational data in source format.
28    
29    It can also be use with C<WebPAC::Tree> to produce tree hierarchies.
30    
31  Lookups are defined in C<config/lookup.pm>.  Lookups are defined in C<conf/lookup/isis.pm>.
32    
33  C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and  C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and
34  C<val>. Optional parametar C<eval> is perl code to evaluate before storing  C<val>. Optional parametar C<eval> is perl code to evaluate before storing
35  value in index.  value in lookup.
36    
37   my $lookup => [   @lookup = [
38    { 'key' => 'd:v900', 'val' => 'v250^a' },    { 'key' => 'd:v900', 'val' => 'v250^a' },
39    { 'eval' => '"v901^a" eq "Područje"',    { 'eval' => '"v901^a" eq "Područje"',
40      'key' => 'pa:v561^4:v562^4:v461^1',      'key' => 'pa:v561^4:v562^4:v461^1',
41      'val' => 'v900' },      'val' => 'v900' },
42   ];   ];
43    
44    Just for a reference, lookup data is internally stored in
45    C<< $self->{'_lookup_data'} >>.
46    
47  =head1 FUNCTIONS  =head1 FUNCTIONS
48    
# Line 46  value in index. Line 50  value in index.
50    
51  Create new lookup object.  Create new lookup object.
52    
53    my $lookup = new WebPAC::Normalize::Lookup(    my $lookup = new WebPAC::Lookup(
54          config => '/path/to/conf/lookup/lookup.pm',          lookup_file => '/path/to/conf/lookup/lookup.pm',
55            is_lookup_regex => 'lookup{[^\{\}]+}';
56            save_lookup_regex => 'lookup{([^\{\}]+)}';
57    );    );
58    
59  =cut  =cut
# Line 59  sub new { Line 65  sub new {
65    
66          my $log = $self->_get_logger();          my $log = $self->_get_logger();
67    
68          my $config = $self->{'config'} || $log->logconfess("need path to lookup file in config parametar");          my $lookup_file = $self->{'lookup_file'} || $log->logconfess("need path to lookup file in lookup_file parametar");
69    
70          my $lookup_code = read_file($config) || $log->logconfess("can't read lookup file $config: $!");          my $lookup_code = read_file($lookup_file) || $log->logconfess("can't read lookup file $lookup_file: $!");
71    
72          {          if ($lookup_file =~ m#\.pm$#) {
73                  no strict 'vars';                  no strict 'vars';
74                  do $config or $log->logdie("Failed to read configuration parameters '$config' $! $@");                  do $lookup_file or $log->logdie("Failed to read configuration parameters '$lookup_file' $! $@");
75                  $self->{'lookup_def'} = \@lookup || $log->logdie("lookup config doesn't produce \@lookup array");                  $self->{'lookup_def'} = \@lookup || $log->logdie("lookup config $lookup_file doesn't produce \@lookup array");
76            } elsif ($lookup_file =~ m#\.(:?yml|yaml)$#) {
77                    my $yaml = LoadFile( $lookup_file ) || $log->logdie("lookup YAML file $lookup_file error: $!");
78                    $self->{'lookup_def'} = $yaml->{lookup} || $log->logdie("lookup YAML file $lookup_file should begin with 'lookup:'");
79            } else {
80                    $log->logide("unsupported lookup file $lookup_file");
81          }          }
82            $log->debug("lookup_def: " . Dumper( $self->{lookup_def} ));
83    
84            $log->logconfess("lookup config file isn't ARRAY but ", sub { Dumper( $self->{'lookup_def'} ) }) if ($self->{'lookup_def'} !~ /ARRAY/o);
85    
86            $self->{'is_lookup_regex'} ||= 'lookup{[^\{\}]+}';
87            $self->{'save_lookup_regex'} ||= 'lookup{([^\{\}]+)}';
88    
89    
90          $log->logconfess("lookup config file isn't ARRAY") if ($self->{'lookup_def'} !~ /ARRAY/o);          $self->{'LOOKUP_REGEX'} = qr/$self->{'is_lookup_regex'}/;
91            $self->{'LOOKUP_REGEX_SAVE'} = qr/$self->{'save_lookup_regex'}/;
92    
93            $log->debug("regexps lookup:", $self->{'LOOKUP_REGEX'}, " save:", $self->{'LOOKUP_REGEX_SAVE'});
94    
95          $self ? return $self : return undef;          $self ? return $self : return undef;
96  }  }
97    
98  =head2 create_lookup  =head2 add
99    
100  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
101    
102   $self->create_lookup($rec, @lookups);   $self->add($rec);
103    
104  Called internally by C<open_*> methods.  Returns true if this record produced lookup.
105    
106  =cut  =cut
107    
108  sub create_lookup {  sub add {
109          my $self = shift;          my $self = shift;
110    
111          my $log = $self->_get_logger();          my $log = $self->_get_logger();
112    
113          my $rec = shift || $log->logconfess("need record to create lookup");          my $rec = shift || $log->logconfess("need record to create lookup");
114          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
115            $log->logconfess("need HASH as first argument!") if ($self->{'lookup_def'} !~ /ARRAY/o);
116    
117            my $n = 0;
118    
119            foreach my $i (@{ $self->{'lookup_def'} }) {
120                    $log->logconfess("need key in ", Dumper($i) ) unless defined($i->{'key'});
121                    $log->logconfess("need val in ", Dumper($i) ) unless defined($i->{'val'});
122    
123          foreach my $i ($self->{'loookup_def'}) {                  $n++;
                 $log->logconfess("need key") unless defined($i->{'key'});  
                 $log->logconfess("need val") unless defined($i->{'val'});  
124    
125                  if (defined($i->{'eval'})) {                  if (defined($i->{'eval'})) {
126                          # eval first, so we can skip fill_in for key and val                          # eval first, so we can skip fill_in for key and val
# Line 103  sub create_lookup { Line 129  sub create_lookup {
129                                  my $key = $self->fill_in($rec,$i->{'key'}) || next;                                  my $key = $self->fill_in($rec,$i->{'key'}) || next;
130                                  my @val = $self->fill_in($rec,$i->{'val'}) || next;                                  my @val = $self->fill_in($rec,$i->{'val'}) || next;
131                                  $log->debug("stored $key = ",sub { join(" | ",@val) });                                  $log->debug("stored $key = ",sub { join(" | ",@val) });
132                                  push @{$self->{'lookup'}->{$key}}, @val;                                  push @{$self->{'_lookup_data'}->{$key}}, @val;
133                          }                          }
134                  } else {                  } else {
135                          my $key = $self->fill_in($rec,$i->{'key'}) || next;                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
136                          my @val = $self->fill_in($rec,$i->{'val'}) || next;                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
137                          $log->debug("stored $key = ",sub { join(" | ",@val) });                          $log->debug("stored $key = ",sub { join(" | ",@val) });
138                          push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'_lookup_data'}->{$key}}, @val;
139                  }                  }
140          }          }
141    
142            return $n;
143    }
144    
145    =head2 lookup
146    
147    Perform lookups on format supplied to it.
148    
149     my $text = $lookup->lookup('lookup{v900}');
150    
151    Lookups can be nested (like lookup{B<d:>lookup{B<a:>lookup{B<v900>}}}).
152    
153    =cut
154    
155    sub lookup {
156            my $self = shift;
157    
158            my $log = $self->_get_logger();
159    
160            my $tmp = shift || $log->logconfess("need format");
161    
162            if ($tmp =~ $self->{'LOOKUP_REGEX'}) {
163                    my @in = ( $tmp );
164    
165                    my @out;
166                    while (my $f = shift @in) {
167                            if ($f =~ $self->{'LOOKUP_REGEX_SAVE'}) {
168                                    my $k = $1;
169                                    if ($self->{'_lookup_data'}->{$k}) {
170                                            foreach my $nv (@{$self->{'_lookup_data'}->{$k}}) {
171                                                    my $tmp2 = $f;
172                                                    $tmp2 =~ s/lookup{$k}/$nv/g;
173                                                    push @in, $tmp2;
174                                            }
175                                    } else {
176                                            undef $f;
177                                    }
178                            } elsif ($f) {
179                                    push @out, $f;
180                            }
181                    }
182                    $log->debug("lookup for: ",$tmp, " returned: ", join(", ",@out));
183    
184                    $log->logconfess("return is array and it's not expected!") unless wantarray;
185    
186                    return @out;
187            } else {
188                    return $tmp;
189            }
190    }
191    
192    =head2 regex
193    
194    Returns precompiled regex for lookup format.
195    
196     if ($foo =~ $lookup->reges) { ... }
197    
198    =cut
199    
200    sub regex {
201            my $self = shift;
202    
203            return $self->{'LOOKUP_REGEX'};
204  }  }
205    
206  =head1 AUTHOR  =head1 AUTHOR
# Line 127  under the same terms as Perl itself. Line 216  under the same terms as Perl itself.
216    
217  =cut  =cut
218    
219  1; # End of WebPAC::Normalize::Lookup  1; # End of WebPAC::Lookup
Legend:
Removed from v.3  
changed lines
  Added in v.330
  ViewVC Help
Powered by ViewVC 1.1.26