/[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 234 by dpavlin, Tue Dec 6 19:41:17 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    
83          $log->logconfess("lookup config file isn't ARRAY") 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);
84    
85            $self->{'is_lookup_regex'} ||= 'lookup{[^\{\}]+}';
86            $self->{'save_lookup_regex'} ||= 'lookup{([^\{\}]+)}';
87    
88    
89            $self->{'LOOKUP_REGEX'} = qr/$self->{'is_lookup_regex'}/;
90            $self->{'LOOKUP_REGEX_SAVE'} = qr/$self->{'save_lookup_regex'}/;
91    
92            $log->debug("regexps: ", $self->{'LOOKUP_REGEX'}, " ", $self->{'LOOKUP_REGEX_SAVE'});
93    
94          $self ? return $self : return undef;          $self ? return $self : return undef;
95  }  }
96    
97  =head2 create_lookup  =head2 add
98    
99  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
100    
101   $self->create_lookup($rec, @lookups);   $self->add($rec);
102    
103  Called internally by C<open_*> methods.  Returns true if this record produced lookup.
104    
105  =cut  =cut
106    
107  sub create_lookup {  sub add($) {
108          my $self = shift;          my $self = shift;
109    
110          my $log = $self->_get_logger();          my $log = $self->_get_logger();
111    
112          my $rec = shift || $log->logconfess("need record to create lookup");          my $rec = shift || $log->logconfess("need record to create lookup");
113          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
114            $log->logconfess("need HASH as first argument!") if ($self->{'lookup_def'} !~ /ARRAY/o);
115    
116            my $n = 0;
117    
118          foreach my $i ($self->{'loookup_def'}) {          foreach my $i (@{ $self->{'lookup_def'} }) {
119                  $log->logconfess("need key") unless defined($i->{'key'});                  $log->logconfess("need key") unless defined($i->{'key'});
120                  $log->logconfess("need val") unless defined($i->{'val'});                  $log->logconfess("need val") unless defined($i->{'val'});
121    
122                    $n++;
123    
124                  if (defined($i->{'eval'})) {                  if (defined($i->{'eval'})) {
125                          # eval first, so we can skip fill_in for key and val                          # eval first, so we can skip fill_in for key and val
126                          my $eval = $self->fill_in($rec,$i->{'eval'}) || next;                          my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
# Line 103  sub create_lookup { Line 128  sub create_lookup {
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                  } else {                  } else {
134                          my $key = $self->fill_in($rec,$i->{'key'}) || next;                          my $key = $self->fill_in($rec,$i->{'key'}) || next;
135                          my @val = $self->fill_in($rec,$i->{'val'}) || next;                          my @val = $self->fill_in($rec,$i->{'val'}) || next;
136                          $log->debug("stored $key = ",sub { join(" | ",@val) });                          $log->debug("stored $key = ",sub { join(" | ",@val) });
137                          push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'_lookup_data'}->{$key}}, @val;
138                    }
139            }
140    
141            return $n;
142    }
143    
144    =head2 lookup
145    
146    Perform lookups on format supplied to it.
147    
148     my $text = $lookup->lookup('[v900]');
149    
150    Lookups can be nested (like C<[d:[a:[v900]]]>).
151    
152    =cut
153    
154    sub lookup {
155            my $self = shift;
156    
157            my $log = $self->_get_logger();
158    
159            my $tmp = shift || $log->logconfess("need format");
160    
161            if ($tmp =~ $self->{'LOOKUP_REGEX'}) {
162                    my @in = ( $tmp );
163    
164                    $log->debug("lookup for: ",$tmp);
165    
166                    my @out;
167                    while (my $f = shift @in) {
168                            if ($f =~ $self->{'LOOKUP_REGEX_SAVE'}) {
169                                    my $k = $1;
170                                    if ($self->{'_lookup_data'}->{$k}) {
171                                            foreach my $nv (@{$self->{'_lookup_data'}->{$k}}) {
172                                                    my $tmp2 = $f;
173                                                    $tmp2 =~ s/lookup{$k}/$nv/g;
174                                                    push @in, $tmp2;
175                                            }
176                                    } else {
177                                            undef $f;
178                                    }
179                            } elsif ($f) {
180                                    push @out, $f;
181                            }
182                  }                  }
183                    $log->logconfess("return is array and it's not expected!") unless wantarray;
184                    return @out;
185            } else {
186                    return $tmp;
187          }          }
188  }  }
189    
190    =head2 regex
191    
192    Returns precompiled regex for lookup format.
193    
194     if ($foo =~ $lookup->reges) { ... }
195    
196    =cut
197    
198    sub regex {
199            my $self = shift;
200    
201            return $self->{'LOOKUP_REGEX'};
202    }
203    
204  =head1 AUTHOR  =head1 AUTHOR
205    
206  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>  Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
# Line 127  under the same terms as Perl itself. Line 214  under the same terms as Perl itself.
214    
215  =cut  =cut
216    
217  1; # End of WebPAC::Normalize::Lookup  1; # End of WebPAC::Lookup
Legend:
Removed from v.3  
changed lines
  Added in v.234
  ViewVC Help
Powered by ViewVC 1.1.26