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',
  );

=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 ? return $self : return undef;
}

=head2 add

Create lookup from record using lookup definition.

 $self->create_lookup($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;
}

=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			use WebPAC::Common;
7
8			use base qw/WebPAC::Common/;
9			use File::Slurp;
10	dpavlin	4	use Data::Dumper;
11	dpavlin	3
12			=head1 NAME
13
14	dpavlin	4	WebPAC::Lookup - simple normalisation plugin to produce lookup
15	dpavlin	3
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	dpavlin	4	to different records in source files. This will enable you to resolve
28			relational data in source format.
29	dpavlin	3
30	dpavlin	4	It can also be use with C<WebPAC::Tree> to produce tree hierarchies.
31	dpavlin	3
32	dpavlin	4	Lookups are defined in C<conf/lookup/isis.pm>.
33
34	dpavlin	3	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	dpavlin	4	value in lookup.
37	dpavlin	3
38	dpavlin	4	@lookup = [
39	dpavlin	3	{ '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	dpavlin	4	my $lookup = new WebPAC::Lookup(
53			lookup_file => '/path/to/conf/lookup/lookup.pm',
54	dpavlin	3	);
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	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			{
70			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	3	}
74
75	dpavlin	4	$log->logconfess("lookup config file isn't ARRAY", sub { Dumper( $self->{'lookup_def'} ) }) if ($self->{'lookup_def'} !~ /ARRAY/o);
76	dpavlin	3
77			$self ? return $self : return undef;
78			}
79
80	dpavlin	4	=head2 add
81	dpavlin	3
82			Create lookup from record using lookup definition.
83
84	dpavlin	4	$self->create_lookup($rec);
85	dpavlin	3
86	dpavlin	4	Returns true if this record produced lookup.
87	dpavlin	3
88			=cut
89
90	dpavlin	4	sub add($) {
91	dpavlin	3	my $self = shift;
92
93			my $log = $self->_get_logger();
94
95			my $rec = shift \|\| $log->logconfess("need record to create lookup");
96			$log->logconfess("need HASH as first argument!") if ($rec !~ /HASH/o);
97	dpavlin	4	$log->logconfess("need HASH as first argument!") if ($self->{'lookup_def'} !~ /ARRAY/o);
98	dpavlin	3
99	dpavlin	4	my $n = 0;
100
101			foreach my $i (@{ $self->{'lookup_def'} }) {
102	dpavlin	3	$log->logconfess("need key") unless defined($i->{'key'});
103			$log->logconfess("need val") unless defined($i->{'val'});
104
105	dpavlin	4	$n++;
106
107	dpavlin	3	if (defined($i->{'eval'})) {
108			# eval first, so we can skip fill_in for key and val
109			my $eval = $self->fill_in($rec,$i->{'eval'}) \|\| next;
110			if ($self->_eval($eval)) {
111			my $key = $self->fill_in($rec,$i->{'key'}) \|\| next;
112			my @val = $self->fill_in($rec,$i->{'val'}) \|\| next;
113			$log->debug("stored $key = ",sub { join(" \| ",@val) });
114			push @{$self->{'lookup'}->{$key}}, @val;
115			}
116			} else {
117			my $key = $self->fill_in($rec,$i->{'key'}) \|\| next;
118			my @val = $self->fill_in($rec,$i->{'val'}) \|\| next;
119			$log->debug("stored $key = ",sub { join(" \| ",@val) });
120			push @{$self->{'lookup'}->{$key}}, @val;
121			}
122			}
123	dpavlin	4
124			return $n;
125	dpavlin	3	}
126
127			=head1 AUTHOR
128
129			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
130
131			=head1 COPYRIGHT & LICENSE
132
133			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
134
135			This program is free software; you can redistribute it and/or modify it
136			under the same terms as Perl itself.
137
138			=cut
139
140	dpavlin	4	1; # End of WebPAC::Lookup