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

Contents of /trunk/lib/WebPAC/Lookup.pm

Parent Directory Parent Directory | Revision Log Revision Log


Revision 393 - (show annotations)
Wed Feb 15 14:49:48 2006 UTC (18 years, 1 month ago) by dpavlin
File size: 5501 byte(s)
 r445@llin:  dpavlin | 2006-01-22 14:41:41 +0100
 indent fix

1 package WebPAC::Lookup;
2
3 use warnings;
4 use strict;
5
6 use base qw/WebPAC::Common WebPAC::Normalize/;
7 use File::Slurp;
8 use YAML qw/LoadFile/;
9 use Data::Dumper;
10
11 =head1 NAME
12
13 WebPAC::Lookup - simple normalisation plugin to produce lookup
14
15 =head1 VERSION
16
17 Version 0.02
18
19 =cut
20
21 our $VERSION = '0.02';
22
23 =head1 SYNOPSIS
24
25 This module will produce in-memory lookups for easy resolution of lookups
26 to different records in source files. This will enable you to resolve
27 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<conf/lookup/isis.pm>.
32
33 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
35 value in lookup.
36
37 @lookup = [
38 { 'key' => 'd:v900', 'val' => 'v250^a' },
39 { 'eval' => '"v901^a" eq "Podruèje"',
40 'key' => 'pa:v561^4:v562^4:v461^1',
41 'val' => 'v900' },
42 ];
43
44 Just for a reference, lookup data is internally stored in
45 C<< $self->{'_lookup_data'} >>.
46
47 =head1 FUNCTIONS
48
49 =head2 new
50
51 Create new lookup object.
52
53 my $lookup = new WebPAC::Lookup(
54 lookup_file => '/path/to/conf/lookup/lookup.pm',
55 is_lookup_regex => 'lookup{[^\{\}]+}';
56 save_lookup_regex => 'lookup{([^\{\}]+)}';
57 );
58
59 =cut
60
61 sub new {
62 my $class = shift;
63 my $self = {@_};
64 bless($self, $class);
65
66 my $log = $self->_get_logger();
67
68 my $lookup_file = $self->{'lookup_file'} || $log->logconfess("need path to lookup file in lookup_file parametar");
69
70 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';
74 do $lookup_file or $log->logdie("Failed to read configuration parameters '$lookup_file' $! $@");
75 $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 $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;
96 }
97
98 =head2 add
99
100 Create lookup from record using lookup definition.
101
102 $self->add($rec);
103
104 Returns true if this record produced lookup.
105
106 =cut
107
108 sub add {
109 my $self = shift;
110
111 my $log = $self->_get_logger();
112
113 my $rec = shift || $log->logconfess("need record to create lookup");
114 $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 $n++;
124
125 if (defined($i->{'eval'})) {
126 # eval first, so we can skip fill_in for key and val
127 my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
128 if ($self->_eval($eval)) {
129 my $key = $self->fill_in($rec,$i->{'key'}) || next;
130 my @val = $self->fill_in($rec,$i->{'val'}) || next;
131 $log->debug("stored $key = ",sub { join(" | ",@val) });
132 push @{$self->{'_lookup_data'}->{$key}}, @val;
133 }
134 } else {
135 my $key = $self->fill_in($rec,$i->{'key'}) || next;
136 my @val = $self->fill_in($rec,$i->{'val'}) || next;
137 $log->debug("stored $key = ",sub { join(" | ",@val) });
138 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
207
208 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
209
210 =head1 COPYRIGHT & LICENSE
211
212 Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
213
214 This program is free software; you can redistribute it and/or modify it
215 under the same terms as Perl itself.
216
217 =cut
218
219 1; # End of WebPAC::Lookup

  ViewVC Help
Powered by ViewVC 1.1.26