lib/WebPAC/Lookup.pm

package WebPAC::Lookup;

use warnings;
use strict;

use base qw/WebPAC::Common WebPAC::Lookup::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-2006 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	package WebPAC::Lookup;
2
3	use warnings;
4	use strict;
5
6	use base qw/WebPAC::Common WebPAC::Lookup::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.03
18
19	=cut
20
21	our $VERSION = '0.03';
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	=head1 FUNCTIONS
45
46	=head2 new
47
48	Create new lookup object.
49
50	my $lookup = new WebPAC::Lookup(
51	lookup_file => '/path/to/conf/lookup/lookup.pm',
52	is_lookup_regex => 'lookup{[^\{\}]+}';
53	save_lookup_regex => 'lookup{([^\{\}]+)}';
54	);
55
56	=cut
57
58	sub new {
59	my $class = shift;
60	my $self = {@_};
61	bless($self, $class);
62
63	my $log = $self->_get_logger();
64
65	my $lookup_file = $self->{'lookup_file'} \|\| $log->logconfess("need path to lookup file in lookup_file parametar");
66
67	my $lookup_code = read_file($lookup_file) \|\| $log->logconfess("can't read lookup file $lookup_file: $!");
68
69	if ($lookup_file =~ m#\.pm$#) {
70	no strict 'vars';
71	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	} 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	}
79	$log->debug("lookup_def: " . Dumper( $self->{lookup_def} ));
80
81	$log->logconfess("lookup config file isn't ARRAY but ", sub { Dumper( $self->{'lookup_def'} ) }) if ($self->{'lookup_def'} !~ /ARRAY/o);
82
83	$self->{'is_lookup_regex'} \|\|= 'lookup{[^\{\}]+}';
84	$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	$log->debug("regexps lookup:", $self->{'LOOKUP_REGEX'}, " save:", $self->{'LOOKUP_REGEX_SAVE'});
91
92	$self ? return $self : return undef;
93	}
94
95	=head2 add
96
97	Create lookup from record using lookup definition.
98
99	$self->add($rec);
100
101	Returns true if this record produced lookup.
102
103	=cut
104
105	sub add {
106	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	$log->logconfess("need HASH as first argument!") if ($self->{'lookup_def'} !~ /ARRAY/o);
113
114	my $n = 0;
115
116	foreach my $i (@{ $self->{'lookup_def'} }) {
117	$log->logconfess("need key in ", Dumper($i) ) unless defined($i->{'key'});
118	$log->logconfess("need val in ", Dumper($i) ) unless defined($i->{'val'});
119
120	$n++;
121
122	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	push @{$self->{'_lookup_data'}->{$key}}, @val;
130	}
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	push @{$self->{'_lookup_data'}->{$key}}, @val;
136	}
137	}
138
139	return $n;
140	}
141
142	=head2 lookup
143
144	Perform lookups on format supplied to it.
145
146	my $text = $lookup->lookup('lookup{v900}');
147
148	Lookups can be nested (like lookup{B<d:>lookup{B<a:>lookup{B<v900>}}}).
149
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	if ($tmp =~ $self->{'LOOKUP_REGEX'}) {
160	my @in = ( $tmp );
161
162	my @out;
163	while (my $f = shift @in) {
164	if ($f =~ $self->{'LOOKUP_REGEX_SAVE'}) {
165	my $k = $1;
166	if ($self->{'_lookup_data'}->{$k}) {
167	foreach my $nv (@{$self->{'_lookup_data'}->{$k}}) {
168	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	$log->debug("lookup for: ",$tmp, " returned: ", join(", ",@out));
180
181	$log->logconfess("return is array and it's not expected!") unless wantarray;
182
183	return @out;
184	} else {
185	return $tmp;
186	}
187	}
188
189	=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	=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	=head1 AUTHOR
217
218	Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
219
220	=head1 COPYRIGHT & LICENSE
221
222	Copyright 2005-2006 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	1; # End of WebPAC::Lookup