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.02

=cut

our $VERSION = '0.02';

=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' },
 ];

Just for a reference, lookup data is internally stored in
C<< $self->{'_lookup_data'} >>.

=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('[v900]');

Lookups can be nested (like C<[d:[a:[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 );

                $log->debug("lookup for: ",$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->logconfess("return is array and it's not expected!") unless wantarray;
                return @out;
        } else {
                return $tmp;
        }
}

=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	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('[v900]');
150
151	Lookups can be nested (like C<[d:[a:[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	$log->debug("lookup for: ",$tmp);
166
167	my @out;
168	while (my $f = shift @in) {
169	if ($f =~ $self->{'LOOKUP_REGEX_SAVE'}) {
170	my $k = $1;
171	if ($self->{'_lookup_data'}->{$k}) {
172	foreach my $nv (@{$self->{'_lookup_data'}->{$k}}) {
173	my $tmp2 = $f;
174	$tmp2 =~ s/lookup{$k}/$nv/g;
175	push @in, $tmp2;
176	}
177	} else {
178	undef $f;
179	}
180	} elsif ($f) {
181	push @out, $f;
182	}
183	}
184	$log->logconfess("return is array and it's not expected!") unless wantarray;
185	return @out;
186	} else {
187	return $tmp;
188	}
189	}
190
191	=head2 regex
192
193	Returns precompiled regex for lookup format.
194
195	if ($foo =~ $lookup->reges) { ... }
196
197	=cut
198
199	sub regex {
200	my $self = shift;
201
202	return $self->{'LOOKUP_REGEX'};
203	}
204
205	=head1 AUTHOR
206
207	Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
208
209	=head1 COPYRIGHT & LICENSE
210
211	Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
212
213	This program is free software; you can redistribute it and/or modify it
214	under the same terms as Perl itself.
215
216	=cut
217
218	1; # End of WebPAC::Lookup