lib/WebPAC/Lookup.pm

package WebPAC::Lookup;

use warnings;
use strict;

use WebPAC::Common;

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

=head1 NAME

WebPAC::Lookup - simple normalisation plugin to produce lookup

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=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: $!");

        {
                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");
        }

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