lib/WebPAC/Lookup.pm

package WebPAC::Normalize::Lookup;

use warnings;
use strict;

use WebPAC::Common;

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

=head1 NAME

WebPAC::Normalize::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. It can also be use with
C<WebPAC::Normalize::Tree> to produce tree hierarchies.

Lookups are defined in C<config/lookup.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 index.

 my $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::Normalize::Lookup(
        config => '/path/to/conf/lookup/lookup.pm',
  );

=cut

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

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

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

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

        {
                no strict 'vars';
                do $config or $log->logdie("Failed to read configuration parameters '$config' $! $@");
                $self->{'lookup_def'} = \@lookup || $log->logdie("lookup config doesn't produce \@lookup array");
        }

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

        $self ? return $self : return undef;
}

=head2 create_lookup

Create lookup from record using lookup definition.

 $self->create_lookup($rec, @lookups);

Called internally by C<open_*> methods.

=cut

sub create_lookup {
        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);

        foreach my $i ($self->{'loookup_def'}) {
                $log->logconfess("need key") unless defined($i->{'key'});
                $log->logconfess("need val") unless defined($i->{'val'});

                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;
                }
        }
}

=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::Normalize::Lookup
1	package WebPAC::Normalize::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
11	=head1 NAME
12
13	WebPAC::Normalize::Lookup - simple normalisation plugin to produce lookup
14
15	=head1 VERSION
16
17	Version 0.01
18
19	=cut
20
21	our $VERSION = '0.01';
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. It can also be use with
27	C<WebPAC::Normalize::Tree> to produce tree hierarchies.
28
29	Lookups are defined in C<config/lookup.pm>.
30
31	C<lookup> argument is an array of lookups to create. Each lookup must have C<key> and
32	C<val>. Optional parametar C<eval> is perl code to evaluate before storing
33	value in index.
34
35	my $lookup => [
36	{ 'key' => 'd:v900', 'val' => 'v250^a' },
37	{ 'eval' => '"v901^a" eq "Podruèje"',
38	'key' => 'pa:v561^4:v562^4:v461^1',
39	'val' => 'v900' },
40	];
41
42
43	=head1 FUNCTIONS
44
45	=head2 new
46
47	Create new lookup object.
48
49	my $lookup = new WebPAC::Normalize::Lookup(
50	config => '/path/to/conf/lookup/lookup.pm',
51	);
52
53	=cut
54
55	sub new {
56	my $class = shift;
57	my $self = {@_};
58	bless($self, $class);
59
60	my $log = $self->_get_logger();
61
62	my $config = $self->{'config'} \|\| $log->logconfess("need path to lookup file in config parametar");
63
64	my $lookup_code = read_file($config) \|\| $log->logconfess("can't read lookup file $config: $!");
65
66	{
67	no strict 'vars';
68	do $config or $log->logdie("Failed to read configuration parameters '$config' $! $@");
69	$self->{'lookup_def'} = \@lookup \|\| $log->logdie("lookup config doesn't produce \@lookup array");
70	}
71
72	$log->logconfess("lookup config file isn't ARRAY") if ($self->{'lookup_def'} !~ /ARRAY/o);
73
74	$self ? return $self : return undef;
75	}
76
77	=head2 create_lookup
78
79	Create lookup from record using lookup definition.
80
81	$self->create_lookup($rec, @lookups);
82
83	Called internally by C<open_*> methods.
84
85	=cut
86
87	sub create_lookup {
88	my $self = shift;
89
90	my $log = $self->_get_logger();
91
92	my $rec = shift \|\| $log->logconfess("need record to create lookup");
93	$log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
94
95	foreach my $i ($self->{'loookup_def'}) {
96	$log->logconfess("need key") unless defined($i->{'key'});
97	$log->logconfess("need val") unless defined($i->{'val'});
98
99	if (defined($i->{'eval'})) {
100	# eval first, so we can skip fill_in for key and val
101	my $eval = $self->fill_in($rec,$i->{'eval'}) \|\| next;
102	if ($self->_eval($eval)) {
103	my $key = $self->fill_in($rec,$i->{'key'}) \|\| next;
104	my @val = $self->fill_in($rec,$i->{'val'}) \|\| next;
105	$log->debug("stored $key = ",sub { join(" \| ",@val) });
106	push @{$self->{'lookup'}->{$key}}, @val;
107	}
108	} else {
109	my $key = $self->fill_in($rec,$i->{'key'}) \|\| next;
110	my @val = $self->fill_in($rec,$i->{'val'}) \|\| next;
111	$log->debug("stored $key = ",sub { join(" \| ",@val) });
112	push @{$self->{'lookup'}->{$key}}, @val;
113	}
114	}
115	}
116
117	=head1 AUTHOR
118
119	Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
120
121	=head1 COPYRIGHT & LICENSE
122
123	Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
124
125	This program is free software; you can redistribute it and/or modify it
126	under the same terms as Perl itself.
127
128	=cut
129
130	1; # End of WebPAC::Normalize::Lookup