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	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	);
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	{
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	}
74
75	$log->logconfess("lookup config file isn't ARRAY", sub { Dumper( $self->{'lookup_def'} ) }) if ($self->{'lookup_def'} !~ /ARRAY/o);
76
77	$self ? return $self : return undef;
78	}
79
80	=head2 add
81
82	Create lookup from record using lookup definition.
83
84	$self->create_lookup($rec);
85
86	Returns true if this record produced lookup.
87
88	=cut
89
90	sub add($) {
91	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	$log->logconfess("need HASH as first argument!") if ($self->{'lookup_def'} !~ /ARRAY/o);
98
99	my $n = 0;
100
101	foreach my $i (@{ $self->{'lookup_def'} }) {
102	$log->logconfess("need key") unless defined($i->{'key'});
103	$log->logconfess("need val") unless defined($i->{'val'});
104
105	$n++;
106
107	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
124	return $n;
125	}
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	1; # End of WebPAC::Lookup