/[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 7 by dpavlin, Sat Jul 16 16:00:19 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;
# Line 7  use WebPAC::Common; Line 7  use WebPAC::Common;
7    
8  use base qw/WebPAC::Common/;  use base qw/WebPAC::Common/;
9  use File::Slurp;  use File::Slurp;
10    use Data::Dumper;
11    
12    my $LOOKUP_REGEX = 'lookup{[^\{\}]+}';
13    my $LOOKUP_REGEX_SAVE = 'lookup{([^\{\}]+)}';
14    
15  =head1 NAME  =head1 NAME
16    
17  WebPAC::Normalize::Lookup - simple normalisation plugin to produce lookup  WebPAC::Lookup - simple normalisation plugin to produce lookup
18    
19  =head1 VERSION  =head1 VERSION
20    
# Line 23  our $VERSION = '0.01'; Line 27  our $VERSION = '0.01';
27  =head1 SYNOPSIS  =head1 SYNOPSIS
28    
29  This module will produce in-memory lookups for easy resolution of lookups  This module will produce in-memory lookups for easy resolution of lookups
30  to different records in source files. It can also be use with  to different records in source files. This will enable you to resolve
31  C<WebPAC::Normalize::Tree> to produce tree hierarchies.  relational data in source format.
32    
33    It can also be use with C<WebPAC::Tree> to produce tree hierarchies.
34    
35  Lookups are defined in C<config/lookup.pm>.  Lookups are defined in C<conf/lookup/isis.pm>.
36    
37  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
38  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
39  value in index.  value in lookup.
40    
41   my $lookup => [   @lookup = [
42    { 'key' => 'd:v900', 'val' => 'v250^a' },    { 'key' => 'd:v900', 'val' => 'v250^a' },
43    { 'eval' => '"v901^a" eq "Područje"',    { 'eval' => '"v901^a" eq "Područje"',
44      'key' => 'pa:v561^4:v562^4:v461^1',      'key' => 'pa:v561^4:v562^4:v461^1',
# Line 46  value in index. Line 52  value in index.
52    
53  Create new lookup object.  Create new lookup object.
54    
55    my $lookup = new WebPAC::Normalize::Lookup(    my $lookup = new WebPAC::Lookup(
56          config => '/path/to/conf/lookup/lookup.pm',          lookup_file => '/path/to/conf/lookup/lookup.pm',
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          {          {
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          }          }
77    
78          $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);
79    
80          $self ? return $self : return undef;          $self ? return $self : return undef;
81  }  }
82    
83  =head2 create_lookup  =head2 add
84    
85  Create lookup from record using lookup definition.  Create lookup from record using lookup definition.
86    
87   $self->create_lookup($rec, @lookups);   $self->add($rec);
88    
89  Called internally by C<open_*> methods.  Returns true if this record produced lookup.
90    
91  =cut  =cut
92    
93  sub create_lookup {  sub add($) {
94          my $self = shift;          my $self = shift;
95    
96          my $log = $self->_get_logger();          my $log = $self->_get_logger();
97    
98          my $rec = shift || $log->logconfess("need record to create lookup");          my $rec = shift || $log->logconfess("need record to create lookup");
99          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);          $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
100            $log->logconfess("need HASH as first argument!") if ($self->{'lookup_def'} !~ /ARRAY/o);
101    
102            my $n = 0;
103    
104          foreach my $i ($self->{'loookup_def'}) {          foreach my $i (@{ $self->{'lookup_def'} }) {
105                  $log->logconfess("need key") unless defined($i->{'key'});                  $log->logconfess("need key") unless defined($i->{'key'});
106                  $log->logconfess("need val") unless defined($i->{'val'});                  $log->logconfess("need val") unless defined($i->{'val'});
107    
108                    $n++;
109    
110                  if (defined($i->{'eval'})) {                  if (defined($i->{'eval'})) {
111                          # eval first, so we can skip fill_in for key and val                          # eval first, so we can skip fill_in for key and val
112                          my $eval = $self->fill_in($rec,$i->{'eval'}) || next;                          my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
# Line 112  sub create_lookup { Line 123  sub create_lookup {
123                          push @{$self->{'lookup'}->{$key}}, @val;                          push @{$self->{'lookup'}->{$key}}, @val;
124                  }                  }
125          }          }
126    
127            return $n;
128    }
129    
130    =head2 lookup
131    
132    Perform lookups on format supplied to it.
133    
134     my $text = $lookup->lookup('[v900]');
135    
136    Lookups can be nested (like C<[d:[a:[v900]]]>).
137    
138    =cut
139    
140    sub lookup {
141            my $self = shift;
142    
143            my $log = $self->_get_logger();
144    
145            my $tmp = shift || $log->logconfess("need format");
146    
147            if ($tmp =~ /$LOOKUP_REGEX/o) {
148                    my @in = ( $tmp );
149    
150                    $log->debug("lookup for: ",$tmp);
151    
152                    my @out;
153                    while (my $f = shift @in) {
154                            if ($f =~ /$LOOKUP_REGEX_SAVE/o) {
155                                    my $k = $1;
156                                    if ($self->{'lookup'}->{$k}) {
157                                            foreach my $nv (@{$self->{'lookup'}->{$k}}) {
158                                                    my $tmp2 = $f;
159                                                    $tmp2 =~ s/lookup{$k}/$nv/g;
160                                                    push @in, $tmp2;
161                                            }
162                                    } else {
163                                            undef $f;
164                                    }
165                            } elsif ($f) {
166                                    push @out, $f;
167                            }
168                    }
169                    $log->logconfess("return is array and it's not expected!") unless wantarray;
170                    return @out;
171            } else {
172                    return $tmp;
173            }
174  }  }
175    
176  =head1 AUTHOR  =head1 AUTHOR
# Line 127  under the same terms as Perl itself. Line 186  under the same terms as Perl itself.
186    
187  =cut  =cut
188    
189  1; # End of WebPAC::Normalize::Lookup  1; # End of WebPAC::Lookup
Legend:
Removed from v.3  
changed lines
  Added in v.7
  ViewVC Help
Powered by ViewVC 1.1.26