lib/WebPAC/Lookup.pm

package WebPAC::Lookup;

use warnings;
use strict;

use base qw/WebPAC::Common WebPAC::Normalize/;
use File::Slurp;
use YAML qw/LoadFile/;
use Data::Dumper;

=head1 NAME

WebPAC::Lookup - simple normalisation plugin to produce lookup

=head1 VERSION

Version 0.03

=cut

our $VERSION = '0.03';

=head1 SYNOPSIS

This module will produce in-memory lookups for easy resolution of lookups
to different records in source files. This will enable you to resolve
relational data in source format.

It can also be use with C<WebPAC::Tree> to produce tree hierarchies.

Lookups are defined in C<conf/lookup/isis.pm>.

C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and
C<val>. Optional parametar C<eval> is perl code to evaluate before storing
value in lookup.

 @lookup = [
  { 'key' => 'd:v900', 'val' => 'v250^a' },
  { 'eval' => '"v901^a" eq "Podruèje"',
    'key' => 'pa:v561^4:v562^4:v461^1',
    'val' => 'v900' },
 ];

=head1 FUNCTIONS

=head2 new

Create new lookup object.

  my $lookup = new WebPAC::Lookup(
        lookup_file => '/path/to/conf/lookup/lookup.pm',
        is_lookup_regex => 'lookup{[^\{\}]+}';
        save_lookup_regex => 'lookup{([^\{\}]+)}';
  );

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        my $log = $self->_get_logger();

        my $lookup_file = $self->{'lookup_file'} || $log->logconfess("need path to lookup file in lookup_file parametar");

        my $lookup_code = read_file($lookup_file) || $log->logconfess("can't read lookup file $lookup_file: $!");

        if ($lookup_file =~ m#\.pm$#) {
                no strict 'vars';
                do $lookup_file or $log->logdie("Failed to read configuration parameters '$lookup_file' $! $@");
                $self->{'lookup_def'} = \@lookup || $log->logdie("lookup config $lookup_file doesn't produce \@lookup array");
        } elsif ($lookup_file =~ m#\.(:?yml|yaml)$#) {
                my $yaml = LoadFile( $lookup_file ) || $log->logdie("lookup YAML file $lookup_file error: $!");
                $self->{'lookup_def'} = $yaml->{lookup} || $log->logdie("lookup YAML file $lookup_file should begin with 'lookup:'");
        } else {
                $log->logide("unsupported lookup file $lookup_file");
        }
        $log->debug("lookup_def: " . Dumper( $self->{lookup_def} ));

        $log->logconfess("lookup config file isn't ARRAY but ", sub { Dumper( $self->{'lookup_def'} ) }) if ($self->{'lookup_def'} !~ /ARRAY/o);

        $self->{'is_lookup_regex'} ||= 'lookup{[^\{\}]+}';
        $self->{'save_lookup_regex'} ||= 'lookup{([^\{\}]+)}';


        $self->{'LOOKUP_REGEX'} = qr/$self->{'is_lookup_regex'}/;
        $self->{'LOOKUP_REGEX_SAVE'} = qr/$self->{'save_lookup_regex'}/;

        $log->debug("regexps lookup:", $self->{'LOOKUP_REGEX'}, " save:", $self->{'LOOKUP_REGEX_SAVE'});

        $self ? return $self : return undef;
}

=head2 add

Create lookup from record using lookup definition.

 $self->add($rec);

Returns true if this record produced lookup.

=cut

sub add {
        my $self = shift;

        my $log = $self->_get_logger();

        my $rec = shift || $log->logconfess("need record to create lookup");
        $log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
        $log->logconfess("need HASH as first argument!") if ($self->{'lookup_def'} !~ /ARRAY/o);

        my $n = 0;

        foreach my $i (@{ $self->{'lookup_def'} }) {
                $log->logconfess("need key in ", Dumper($i) ) unless defined($i->{'key'});
                $log->logconfess("need val in ", Dumper($i) ) unless defined($i->{'val'});

                $n++;

                if (defined($i->{'eval'})) {
                        # eval first, so we can skip fill_in for key and val
                        my $eval = $self->fill_in($rec,$i->{'eval'}) || next;
                        if ($self->_eval($eval)) {
                                my $key = $self->fill_in($rec,$i->{'key'}) || next;
                                my @val = $self->fill_in($rec,$i->{'val'}) || next;
                                $log->debug("stored $key = ",sub { join(" | ",@val) });
                                push @{$self->{'_lookup_data'}->{$key}}, @val;
                        }
                } else {
                        my $key = $self->fill_in($rec,$i->{'key'}) || next;
                        my @val = $self->fill_in($rec,$i->{'val'}) || next;
                        $log->debug("stored $key = ",sub { join(" | ",@val) });
                        push @{$self->{'_lookup_data'}->{$key}}, @val;
                }
        }

        return $n;
}

=head2 lookup

Perform lookups on format supplied to it.

 my $text = $lookup->lookup('lookup{v900}');

Lookups can be nested (like lookup{B<d:>lookup{B<a:>lookup{B<v900>}}}).

=cut

sub lookup {
        my $self = shift;

        my $log = $self->_get_logger();

        my $tmp = shift || $log->logconfess("need format");

        if ($tmp =~ $self->{'LOOKUP_REGEX'}) {
                my @in = ( $tmp );

                my @out;
                while (my $f = shift @in) {
                        if ($f =~ $self->{'LOOKUP_REGEX_SAVE'}) {
                                my $k = $1;
                                if ($self->{'_lookup_data'}->{$k}) {
                                        foreach my $nv (@{$self->{'_lookup_data'}->{$k}}) {
                                                my $tmp2 = $f;
                                                $tmp2 =~ s/lookup{$k}/$nv/g;
                                                push @in, $tmp2;
                                        }
                                } else {
                                        undef $f;
                                }
                        } elsif ($f) {
                                push @out, $f;
                        }
                }
                $log->debug("lookup for: ",$tmp, " returned: ", join(", ",@out));

                $log->logconfess("return is array and it's not expected!") unless wantarray;

                return @out;
        } else {
                return $tmp;
        }
}

=head2 lookup_hash

Returns hash representation of lookup data

  my $l_hash = $lookup->lookup_hash;

=cut

sub lookup_hash {
        my $self = shift;
        return $self->{_lookup_data};
}

=head2 regex

Returns precompiled regex for lookup format.

 if ($foo =~ $lookup->reges) { ... }

=cut

sub regex {
        my $self = shift;

        return $self->{'LOOKUP_REGEX'};
}

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of WebPAC::Lookup
1	dpavlin	4	package WebPAC::Lookup;
2	dpavlin	3
3			use warnings;
4			use strict;
5
6	dpavlin	15	use base qw/WebPAC::Common WebPAC::Normalize/;
7	dpavlin	3	use File::Slurp;
8	dpavlin	234	use YAML qw/LoadFile/;
9	dpavlin	4	use Data::Dumper;
10	dpavlin	3
11			=head1 NAME
12
13	dpavlin	4	WebPAC::Lookup - simple normalisation plugin to produce lookup
14	dpavlin	3
15			=head1 VERSION
16
17	dpavlin	473	Version 0.03
18	dpavlin	3
19			=cut
20
21	dpavlin	473	our $VERSION = '0.03';
22	dpavlin	3
23			=head1 SYNOPSIS
24
25			This module will produce in-memory lookups for easy resolution of lookups
26	dpavlin	4	to different records in source files. This will enable you to resolve
27			relational data in source format.
28	dpavlin	3
29	dpavlin	4	It can also be use with C<WebPAC::Tree> to produce tree hierarchies.
30	dpavlin	3
31	dpavlin	4	Lookups are defined in C<conf/lookup/isis.pm>.
32
33	dpavlin	3	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	dpavlin	4	value in lookup.
36	dpavlin	3
37	dpavlin	4	@lookup = [
38	dpavlin	3	{ '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			=head1 FUNCTIONS
45
46			=head2 new
47
48			Create new lookup object.
49
50	dpavlin	4	my $lookup = new WebPAC::Lookup(
51			lookup_file => '/path/to/conf/lookup/lookup.pm',
52	dpavlin	12	is_lookup_regex => 'lookup{[^\{\}]+}';
53			save_lookup_regex => 'lookup{([^\{\}]+)}';
54	dpavlin	3	);
55
56			=cut
57
58			sub new {
59	dpavlin	393	my $class = shift;
60			my $self = {@_};
61	dpavlin	3	bless($self, $class);
62
63			my $log = $self->_get_logger();
64
65	dpavlin	4	my $lookup_file = $self->{'lookup_file'} \|\| $log->logconfess("need path to lookup file in lookup_file parametar");
66	dpavlin	3
67	dpavlin	4	my $lookup_code = read_file($lookup_file) \|\| $log->logconfess("can't read lookup file $lookup_file: $!");
68	dpavlin	3
69	dpavlin	234	if ($lookup_file =~ m#\.pm$#) {
70	dpavlin	3	no strict 'vars';
71	dpavlin	4	do $lookup_file or $log->logdie("Failed to read configuration parameters '$lookup_file' $! $@");
72			$self->{'lookup_def'} = \@lookup \|\| $log->logdie("lookup config $lookup_file doesn't produce \@lookup array");
73	dpavlin	234	} elsif ($lookup_file =~ m#\.(:?yml\|yaml)$#) {
74			my $yaml = LoadFile( $lookup_file ) \|\| $log->logdie("lookup YAML file $lookup_file error: $!");
75			$self->{'lookup_def'} = $yaml->{lookup} \|\| $log->logdie("lookup YAML file $lookup_file should begin with 'lookup:'");
76			} else {
77			$log->logide("unsupported lookup file $lookup_file");
78	dpavlin	3	}
79	dpavlin	251	$log->debug("lookup_def: " . Dumper( $self->{lookup_def} ));
80	dpavlin	3
81	dpavlin	234	$log->logconfess("lookup config file isn't ARRAY but ", sub { Dumper( $self->{'lookup_def'} ) }) if ($self->{'lookup_def'} !~ /ARRAY/o);
82	dpavlin	3
83	dpavlin	252	$self->{'is_lookup_regex'} \|\|= 'lookup{[^\{\}]+}';
84	dpavlin	12	$self->{'save_lookup_regex'} \|\|= 'lookup{([^\{\}]+)}';
85
86
87			$self->{'LOOKUP_REGEX'} = qr/$self->{'is_lookup_regex'}/;
88			$self->{'LOOKUP_REGEX_SAVE'} = qr/$self->{'save_lookup_regex'}/;
89
90	dpavlin	251	$log->debug("regexps lookup:", $self->{'LOOKUP_REGEX'}, " save:", $self->{'LOOKUP_REGEX_SAVE'});
91	dpavlin	12
92	dpavlin	3	$self ? return $self : return undef;
93			}
94
95	dpavlin	4	=head2 add
96	dpavlin	3
97			Create lookup from record using lookup definition.
98
99	dpavlin	7	$self->add($rec);
100	dpavlin	3
101	dpavlin	4	Returns true if this record produced lookup.
102	dpavlin	3
103			=cut
104
105	dpavlin	251	sub add {
106	dpavlin	3	my $self = shift;
107
108			my $log = $self->_get_logger();
109
110			my $rec = shift \|\| $log->logconfess("need record to create lookup");
111			$log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
112	dpavlin	4	$log->logconfess("need HASH as first argument!") if ($self->{'lookup_def'} !~ /ARRAY/o);
113	dpavlin	3
114	dpavlin	4	my $n = 0;
115
116			foreach my $i (@{ $self->{'lookup_def'} }) {
117	dpavlin	251	$log->logconfess("need key in ", Dumper($i) ) unless defined($i->{'key'});
118			$log->logconfess("need val in ", Dumper($i) ) unless defined($i->{'val'});
119	dpavlin	3
120	dpavlin	4	$n++;
121
122	dpavlin	3	if (defined($i->{'eval'})) {
123			# eval first, so we can skip fill_in for key and val
124			my $eval = $self->fill_in($rec,$i->{'eval'}) \|\| next;
125			if ($self->_eval($eval)) {
126			my $key = $self->fill_in($rec,$i->{'key'}) \|\| next;
127			my @val = $self->fill_in($rec,$i->{'val'}) \|\| next;
128			$log->debug("stored $key = ",sub { join(" \| ",@val) });
129	dpavlin	30	push @{$self->{'_lookup_data'}->{$key}}, @val;
130	dpavlin	3	}
131			} else {
132			my $key = $self->fill_in($rec,$i->{'key'}) \|\| next;
133			my @val = $self->fill_in($rec,$i->{'val'}) \|\| next;
134			$log->debug("stored $key = ",sub { join(" \| ",@val) });
135	dpavlin	30	push @{$self->{'_lookup_data'}->{$key}}, @val;
136	dpavlin	3	}
137			}
138	dpavlin	4
139			return $n;
140	dpavlin	3	}
141
142	dpavlin	7	=head2 lookup
143
144			Perform lookups on format supplied to it.
145
146	dpavlin	330	my $text = $lookup->lookup('lookup{v900}');
147	dpavlin	7
148	dpavlin	330	Lookups can be nested (like lookup{B<d:>lookup{B<a:>lookup{B<v900>}}}).
149	dpavlin	7
150			=cut
151
152			sub lookup {
153			my $self = shift;
154
155			my $log = $self->_get_logger();
156
157			my $tmp = shift \|\| $log->logconfess("need format");
158
159	dpavlin	12	if ($tmp =~ $self->{'LOOKUP_REGEX'}) {
160	dpavlin	7	my @in = ( $tmp );
161
162			my @out;
163			while (my $f = shift @in) {
164	dpavlin	12	if ($f =~ $self->{'LOOKUP_REGEX_SAVE'}) {
165	dpavlin	7	my $k = $1;
166	dpavlin	30	if ($self->{'_lookup_data'}->{$k}) {
167			foreach my $nv (@{$self->{'_lookup_data'}->{$k}}) {
168	dpavlin	7	my $tmp2 = $f;
169			$tmp2 =~ s/lookup{$k}/$nv/g;
170			push @in, $tmp2;
171			}
172			} else {
173			undef $f;
174			}
175			} elsif ($f) {
176			push @out, $f;
177			}
178			}
179	dpavlin	252	$log->debug("lookup for: ",$tmp, " returned: ", join(", ",@out));
180
181	dpavlin	7	$log->logconfess("return is array and it's not expected!") unless wantarray;
182	dpavlin	252
183	dpavlin	7	return @out;
184			} else {
185			return $tmp;
186			}
187			}
188
189	dpavlin	473	=head2 lookup_hash
190
191			Returns hash representation of lookup data
192
193			my $l_hash = $lookup->lookup_hash;
194
195			=cut
196
197			sub lookup_hash {
198			my $self = shift;
199			return $self->{_lookup_data};
200			}
201
202	dpavlin	12	=head2 regex
203
204			Returns precompiled regex for lookup format.
205
206			if ($foo =~ $lookup->reges) { ... }
207
208			=cut
209
210			sub regex {
211			my $self = shift;
212
213			return $self->{'LOOKUP_REGEX'};
214			}
215
216	dpavlin	3	=head1 AUTHOR
217
218			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
219
220			=head1 COPYRIGHT & LICENSE
221
222			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
223
224			This program is free software; you can redistribute it and/or modify it
225			under the same terms as Perl itself.
226
227			=cut
228
229	dpavlin	4	1; # End of WebPAC::Lookup