/[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 251 by dpavlin, Thu Dec 15 14:12:00 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->{'loookup_def'}) {          foreach my $i (@{ $self->{'lookup_def'} }) {
120                  $log->logconfess("need key") unless defined($i->{'key'});                  $log->logconfess("need key in ", Dumper($i) ) unless defined($i->{'key'});
121                  $log->logconfess("need val") unless defined($i->{'val'});                  $log->logconfess("need val in ", Dumper($i) ) unless defined($i->{'val'});
122    
123                    $n++;
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('[v900]');
150    
151    Lookups can be nested (like C<[d:[a:[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                    $log->debug("lookup for: ",$tmp);
166    
167                    my @out;
168                    while (my $f = shift @in) {
169                            if ($f =~ $self->{'LOOKUP_REGEX_SAVE'}) {
170                                    my $k = $1;
171                                    if ($self->{'_lookup_data'}->{$k}) {
172                                            foreach my $nv (@{$self->{'_lookup_data'}->{$k}}) {
173                                                    my $tmp2 = $f;
174                                                    $tmp2 =~ s/lookup{$k}/$nv/g;
175                                                    push @in, $tmp2;
176                                            }
177                                    } else {
178                                            undef $f;
179                                    }
180                            } elsif ($f) {
181                                    push @out, $f;
182                            }
183                  }                  }
184                    $log->logconfess("return is array and it's not expected!") unless wantarray;
185                    return @out;
186            } else {
187                    return $tmp;
188          }          }
189  }  }
190    
191    =head2 regex
192    
193    Returns precompiled regex for lookup format.
194    
195     if ($foo =~ $lookup->reges) { ... }
196    
197    =cut
198    
199    sub regex {
200            my $self = shift;
201    
202            return $self->{'LOOKUP_REGEX'};
203    }
204    
205  =head1 AUTHOR  =head1 AUTHOR
206    
207  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
# Line 127  under the same terms as Perl itself. Line 215  under the same terms as Perl itself.
215    
216  =cut  =cut
217    
218  1; # End of WebPAC::Normalize::Lookup  1; # End of WebPAC::Lookup
Legend:
Removed from v.3  
changed lines
  Added in v.251
  ViewVC Help
Powered by ViewVC 1.1.26