/[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 15 by dpavlin, Sun Jul 17 10:42:23 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 WebPAC::Common;
7    
8  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common WebPAC::Normalize/;
9  use File::Slurp;  use File::Slurp;
10    use Data::Dumper;
11    
12  =head1 NAME  =head1 NAME
13    
14  WebPAC::Normalize::Lookup - simple normalisation plugin to produce lookup  WebPAC::Lookup - simple normalisation plugin to produce lookup
15    
16  =head1 VERSION  =head1 VERSION
17    
# Line 23  our $VERSION = '0.01'; Line 24  our $VERSION = '0.01';
24  =head1 SYNOPSIS  =head1 SYNOPSIS
25    
26  This module will produce in-memory lookups for easy resolution of lookups  This module will produce in-memory lookups for easy resolution of lookups
27  to different records in source files. It can also be use with  to different records in source files. This will enable you to resolve
28  C<WebPAC::Normalize::Tree> to produce tree hierarchies.  relational data in source format.
29    
30  Lookups are defined in C<config/lookup.pm>.  It can also be use with C<WebPAC::Tree> to produce tree hierarchies.
31    
32    Lookups are defined in C<conf/lookup/isis.pm>.
33    
34  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
35  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
36  value in index.  value in lookup.
37    
38   my $lookup => [   @lookup = [
39    { 'key' => 'd:v900', 'val' => 'v250^a' },    { 'key' => 'd:v900', 'val' => 'v250^a' },
40    { 'eval' => '"v901^a" eq "Područje"',    { 'eval' => '"v901^a" eq "Područje"',
41      'key' => 'pa:v561^4:v562^4:v461^1',      'key' => 'pa:v561^4:v562^4:v461^1',
# Line 46  value in index. Line 49  value in index.
49    
50  Create new lookup object.  Create new lookup object.
51    
52    my $lookup = new WebPAC::Normalize::Lookup(    my $lookup = new WebPAC::Lookup(
53          config => '/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 59  sub new { Line 64  sub new {
64    
65          my $log = $self->_get_logger();          my $log = $self->_get_logger();
66    
67          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");
68    
69          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: $!");
70    
71          {          {
72                  no strict 'vars';                  no strict 'vars';
73                  do $config or $log->logdie("Failed to read configuration parameters '$config' $! $@");                  do $lookup_file or $log->logdie("Failed to read configuration parameters '$lookup_file' $! $@");
74                  $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");
75          }          }
76    
77          $log->logconfess("lookup config file isn't ARRAY") 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    
91  =head2 create_lookup  =head2 add
92    
93  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
94    
95   $self->create_lookup($rec, @lookups);   $self->add($rec);
96    
97  Called internally by C<open_*> methods.  Returns true if this record produced lookup.
98    
99  =cut  =cut
100    
101  sub create_lookup {  sub add($) {
102          my $self = shift;          my $self = shift;
103    
104          my $log = $self->_get_logger();          my $log = $self->_get_logger();
105    
106          my $rec = shift || $log->logconfess("need record to create lookup");          my $rec = shift || $log->logconfess("need record to create lookup");
107          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
108            $log->logconfess("need HASH as first argument!") if ($self->{'lookup_def'} !~ /ARRAY/o);
109    
110          foreach my $i ($self->{'loookup_def'}) {          my $n = 0;
111    
112            foreach my $i (@{ $self->{'lookup_def'} }) {
113                  $log->logconfess("need key") unless defined($i->{'key'});                  $log->logconfess("need key") unless defined($i->{'key'});
114                  $log->logconfess("need val") unless defined($i->{'val'});                  $log->logconfess("need val") unless defined($i->{'val'});
115    
116                    $n++;
117    
118                  if (defined($i->{'eval'})) {                  if (defined($i->{'eval'})) {
119                          # eval first, so we can skip fill_in for key and val                          # eval first, so we can skip fill_in for key and val
120                          my $eval = $self->fill_in($rec,$i->{'eval'}) || next;                          my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
# Line 112  sub create_lookup { Line 131  sub create_lookup {
131                          push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'lookup'}->{$key}}, @val;
132                  }                  }
133          }          }
134    
135            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'}->{$k}) {
165                                            foreach my $nv (@{$self->{'lookup'}->{$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
# Line 127  under the same terms as Perl itself. Line 208  under the same terms as Perl itself.
208    
209  =cut  =cut
210    
211  1; # End of WebPAC::Normalize::Lookup  1; # End of WebPAC::Lookup
Legend:
Removed from v.3  
changed lines
  Added in v.15
  ViewVC Help
Powered by ViewVC 1.1.26