lib/WebPAC/Parser.pm

package WebPAC::Parser;

use warnings;
use strict;


use PPI;
use PPI::Dumper;
use Data::Dump qw/dump/;
use File::Slurp;

use base qw/WebPAC::Common WebPAC::Normalize/;

=head1 NAME

WebPAC::Parser - parse perl normalization configuration files and mungle it

=head1 VERSION

Version 0.03

=cut

our $VERSION = '0.03';

=head1 SYNOPSIS

FIXME

=head1 FUNCTIONS

=head2 new

Create new parser object.

  my $parser = new WebPAC::Parser(
        config => new WebPAC::Config(),
        base_path => '/optional/path/to/conf',
  );

=cut

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

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

        $log->logdie("config isn't WebPAC::Config") unless ($self->{config} && $self->{config}->isa('WebPAC::Config'));

        $log->logdie("can't iterate_inputs over this config object") unless ($self->{config}->can('iterate_inputs'));

        $self->read_sources;

        $self->{config}->iterate_inputs( sub {
                my ($input, $database) = @_;
                return unless $self->valid_database_input($database, $input->{name});
                $self->parse_lookups($database,$input->{name});
        } );

        $self ? return $self : return undef;
}

=head2 read_sources

  my $source_files = $parser->read_sources;

Called by L</new>.

=cut

sub read_sources {
        my $self = shift;

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

        my $nr = 0;

        $self->{config}->iterate_inputs( sub {
                my ($input, $database) = @_;

                my $path = $input->{normalize}->{path} || return;
                my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;

                $log->logdie("normalization input $full doesn't exist") unless (-e $full);

                my $s = read_file( $full ) || $log->logdie("can't read $full: $!");

                my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));

                $log->debug("$database/$input_name: adding $path");

                $self->{valid_inputs}->{$database}->{$input_name} = {
                        source => $s,
                        path => $full,
                        usage => 0,
                } unless defined($self->{valid_inputs}->{$database}->{$input_name});

                $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;

                $nr++;
        } );

        $log->debug("found $nr source files");

        return $nr;
}

=head2 parse_lookup

  $parser->parse_lookups($database,$input);

=cut

sub parse_lookups {
        my $self = shift;
        my ($database, $input) = @_;

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

        $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
        $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );

        my $source = $self->{valid_inputs}->{$database}->{$input}->{source};
        my $path = $self->{valid_inputs}->{$database}->{$input}->{path};

        $log->logdie("no source found for database $database input $input path $path") unless ($source);

        $log->info("parsing lookups for $database/$input in $path");

        my $Document = PPI::Document->new( \$source ) || $log->logdie("can't parse source:\n", $self->{source});

        $Document->prune('PPI::Token::Whitespace');
        #$Document->prune('PPI::Token::Operator');

        # Find all the named subroutines

        my $eval_create;
        $self->{_lookup_errors} = ();

        sub _lookup_error {
                my $self = shift;
                my $msg = shift;
                $self->_get_logger->logconfess("error without message?") unless ($msg);
                push @{ $self->{_lookup_errors} }, $msg;
                return '';
        }

        $Document->find( sub {
                        my ($Document,$Element) = @_;

                        $Element->isa('PPI::Token::Word') or return '';
                        $Element->content eq 'lookup' or return '';

                        $log->debug("expansion: ", $Element->snext_sibling);

                        my $args = $Element->snext_sibling;
                
                        my @e = $args->child(0)->elements;
                        $log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);

                        if ($log->is_debug) {
                                my $report = "found " . scalar @e . " elements:\n";

                                foreach my $i ( 0 .. $#e ) {
                                        $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
                                }

                                $log->debug($report);
                        }

                        my $key_element = $e[8]->clone;

                        $log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');

                        $log->debug("key part: ", $key_element);

                        my @key;

                        $key_element->find( sub {
                                my $e = $_[1] || die "no element?";
                                $e->isa('PPI::Token::Word') or return '';
                                $e->content eq 'rec' or return '';

                                my $kf = $e->snext_sibling;

                                $log->debug("key fragment = $kf");

                                push @key, eval $kf;
                                $log->logdie("can't eval { $kf }: $@") if ($@);

                                return 1;
                        });

                        my $key = join('-', @key ) || $log->logdie("no key found!");

                        $log->debug("key = $key");

                        my $create = ' 
                                $coderef = ' . $e[7] . $e[8] . ';
                                foreach my $v ($coderef->()) {
                                        next unless (defined($v) && $v ne \'\');
                                        push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;
                                }
                        ';

                        $log->debug("create: $create");

                        return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
                        return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );

                        $eval_create->{ $e[3] }->{ $e[5] } .= $create;

                        if ($#e < 10) {
                                $e[8]->insert_after( $e[8]->clone );
                                $e[8]->insert_after( $e[7]->clone );
                                $e[8]->insert_after( $e[6]->clone );
                        }

                        $e[7]->remove;
                        $e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );
                        $e[8]->remove;


                        $log->debug(">>> ", $Element->snext_sibling);
        });

        $log->info("create: ", dump($eval_create) );
        $log->info("lookup: ", $Document->serialize );

        if ($self->{debug}) {
                my $Dumper = PPI::Dumper->new( $Document );
                $Dumper->print;
        }

        $log->error("Parser errors: ", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});

        return 1;
}

=head2 valid_database

  my $ok = $parse->valid_database('key');

=cut

sub valid_database {
        my $self = shift;

        my $database = shift || return;
        $database =~ s/['"]//g;

        return defined($self->{valid_inputs}->{$database});
}

=head2 valid_database_input

  my $ok = $parse->valid_database('database_key','input_name');

=cut

sub valid_database_input {
        my $self = shift;

        my ($database,$input) = @_;
        $database =~ s/['"]//g;
        $input =~ s/['"]//g;

        return defined($self->{valid_inputs}->{$database}->{$input});
}

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2006 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::Parser
1	dpavlin	686	package WebPAC::Parser;
2
3			use warnings;
4			use strict;
5
6
7			use PPI;
8			use PPI::Dumper;
9			use Data::Dump qw/dump/;
10			use File::Slurp;
11
12	dpavlin	691	use base qw/WebPAC::Common WebPAC::Normalize/;
13	dpavlin	686
14			=head1 NAME
15
16			WebPAC::Parser - parse perl normalization configuration files and mungle it
17
18			=head1 VERSION
19
20	dpavlin	691	Version 0.03
21	dpavlin	686
22			=cut
23
24	dpavlin	691	our $VERSION = '0.03';
25	dpavlin	686
26			=head1 SYNOPSIS
27
28			FIXME
29
30			=head1 FUNCTIONS
31
32			=head2 new
33
34			Create new parser object.
35
36			my $parser = new WebPAC::Parser(
37			config => new WebPAC::Config(),
38			base_path => '/optional/path/to/conf',
39			);
40
41			=cut
42
43			sub new {
44			my $class = shift;
45			my $self = {@_};
46			bless($self, $class);
47
48			my $log = $self->_get_logger();
49
50			$log->logdie("config isn't WebPAC::Config") unless ($self->{config} && $self->{config}->isa('WebPAC::Config'));
51
52			$log->logdie("can't iterate_inputs over this config object") unless ($self->{config}->can('iterate_inputs'));
53
54	dpavlin	691	$self->read_sources;
55	dpavlin	686
56			$self->{config}->iterate_inputs( sub {
57	dpavlin	689	my ($input, $database) = @_;
58	dpavlin	691	return unless $self->valid_database_input($database, $input->{name});
59			$self->parse_lookups($database,$input->{name});
60			} );
61
62			$self ? return $self : return undef;
63			}
64
65			=head2 read_sources
66
67			my $source_files = $parser->read_sources;
68
69			Called by L</new>.
70
71			=cut
72
73			sub read_sources {
74			my $self = shift;
75
76			my $log = $self->_get_logger();
77
78			my $nr = 0;
79
80			$self->{config}->iterate_inputs( sub {
81			my ($input, $database) = @_;
82
83	dpavlin	686	my $path = $input->{normalize}->{path} \|\| return;
84			my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
85	dpavlin	691
86	dpavlin	686	$log->logdie("normalization input $full doesn't exist") unless (-e $full);
87	dpavlin	691
88	dpavlin	686	my $s = read_file( $full ) \|\| $log->logdie("can't read $full: $!");
89	dpavlin	691
90	dpavlin	689	my $input_name = $input->{name} \|\| $log->logdie("can't deduce name of input: ", dump( $input ));
91	dpavlin	691
92			$log->debug("$database/$input_name: adding $path");
93
94			$self->{valid_inputs}->{$database}->{$input_name} = {
95			source => $s,
96			path => $full,
97			usage => 0,
98			} unless defined($self->{valid_inputs}->{$database}->{$input_name});
99
100			$self->{valid_inputs}->{$database}->{$input_name}->{usage}++;
101
102			$nr++;
103	dpavlin	686	} );
104
105	dpavlin	691	$log->debug("found $nr source files");
106	dpavlin	686
107	dpavlin	691	return $nr;
108	dpavlin	686	}
109
110	dpavlin	691	=head2 parse_lookup
111	dpavlin	686
112	dpavlin	691	$parser->parse_lookups($database,$input);
113
114	dpavlin	686	=cut
115
116	dpavlin	691	sub parse_lookups {
117	dpavlin	686	my $self = shift;
118	dpavlin	691	my ($database, $input) = @_;
119	dpavlin	686
120			my $log = $self->_get_logger();
121
122	dpavlin	691	$log->logdie("invalid database $database" ) unless $self->valid_database( $database );
123			$log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
124	dpavlin	686
125	dpavlin	691	my $source = $self->{valid_inputs}->{$database}->{$input}->{source};
126			my $path = $self->{valid_inputs}->{$database}->{$input}->{path};
127	dpavlin	689
128	dpavlin	691	$log->logdie("no source found for database $database input $input path $path") unless ($source);
129	dpavlin	686
130	dpavlin	691	$log->info("parsing lookups for $database/$input in $path");
131
132			my $Document = PPI::Document->new( \$source ) \|\| $log->logdie("can't parse source:\n", $self->{source});
133
134	dpavlin	686	$Document->prune('PPI::Token::Whitespace');
135			#$Document->prune('PPI::Token::Operator');
136
137			# Find all the named subroutines
138
139			my $eval_create;
140	dpavlin	691	$self->{_lookup_errors} = ();
141	dpavlin	686
142	dpavlin	691	sub _lookup_error {
143			my $self = shift;
144			my $msg = shift;
145			$self->_get_logger->logconfess("error without message?") unless ($msg);
146			push @{ $self->{_lookup_errors} }, $msg;
147	dpavlin	690	return '';
148			}
149
150	dpavlin	686	$Document->find( sub {
151			my ($Document,$Element) = @_;
152
153			$Element->isa('PPI::Token::Word') or return '';
154			$Element->content eq 'lookup' or return '';
155
156	dpavlin	687	$log->debug("expansion: ", $Element->snext_sibling);
157	dpavlin	686
158			my $args = $Element->snext_sibling;
159
160			my @e = $args->child(0)->elements;
161	dpavlin	687	$log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
162	dpavlin	686
163	dpavlin	687	if ($log->is_debug) {
164			my $report = "found " . scalar @e . " elements:\n";
165	dpavlin	686
166	dpavlin	687	foreach my $i ( 0 .. $#e ) {
167			$report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] \|\| 'undef' ), $e[$i]->class );
168			}
169
170			$log->debug($report);
171	dpavlin	686	}
172
173			my $key_element = $e[8]->clone;
174
175	dpavlin	687	$log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
176	dpavlin	686
177	dpavlin	687	$log->debug("key part: ", $key_element);
178	dpavlin	686
179			my @key;
180
181			$key_element->find( sub {
182			my $e = $_[1] \|\| die "no element?";
183			$e->isa('PPI::Token::Word') or return '';
184			$e->content eq 'rec' or return '';
185
186			my $kf = $e->snext_sibling;
187
188	dpavlin	687	$log->debug("key fragment = $kf");
189	dpavlin	686
190			push @key, eval $kf;
191	dpavlin	687	$log->logdie("can't eval { $kf }: $@") if ($@);
192	dpavlin	686
193			return 1;
194			});
195
196	dpavlin	687	my $key = join('-', @key ) \|\| $log->logdie("no key found!");
197	dpavlin	686
198	dpavlin	687	$log->debug("key = $key");
199	dpavlin	686
200			my $create = '
201			$coderef = ' . $e[7] . $e[8] . ';
202			foreach my $v ($coderef->()) {
203			next unless (defined($v) && $v ne \'\');
204			push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;
205			}
206			';
207
208	dpavlin	687	$log->debug("create: $create");
209	dpavlin	686
210	dpavlin	691	return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
211			return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
212	dpavlin	689
213	dpavlin	686	$eval_create->{ $e[3] }->{ $e[5] } .= $create;
214
215			if ($#e < 10) {
216			$e[8]->insert_after( $e[8]->clone );
217			$e[8]->insert_after( $e[7]->clone );
218			$e[8]->insert_after( $e[6]->clone );
219			}
220
221			$e[7]->remove;
222			$e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );
223			$e[8]->remove;
224
225
226	dpavlin	687	$log->debug(">>> ", $Element->snext_sibling);
227	dpavlin	686	});
228
229	dpavlin	687	$log->info("create: ", dump($eval_create) );
230			$log->info("lookup: ", $Document->serialize );
231	dpavlin	686
232	dpavlin	687	if ($self->{debug}) {
233			my $Dumper = PPI::Dumper->new( $Document );
234			$Dumper->print;
235			}
236	dpavlin	686
237	dpavlin	691	$log->error("Parser errors: ", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
238	dpavlin	690
239	dpavlin	687	return 1;
240	dpavlin	686	}
241
242	dpavlin	689	=head2 valid_database
243
244			my $ok = $parse->valid_database('key');
245
246			=cut
247
248			sub valid_database {
249			my $self = shift;
250
251			my $database = shift \|\| return;
252			$database =~ s/['"]//g;
253
254			return defined($self->{valid_inputs}->{$database});
255			}
256
257			=head2 valid_database_input
258
259			my $ok = $parse->valid_database('database_key','input_name');
260
261			=cut
262
263			sub valid_database_input {
264			my $self = shift;
265
266			my ($database,$input) = @_;
267			$database =~ s/['"]//g;
268			$input =~ s/['"]//g;
269
270			return defined($self->{valid_inputs}->{$database}->{$input});
271			}
272
273	dpavlin	686	=head1 AUTHOR
274
275			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
276
277			=head1 COPYRIGHT & LICENSE
278
279			Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
280
281			This program is free software; you can redistribute it and/or modify it
282			under the same terms as Perl itself.
283
284			=cut
285
286			1; # End of WebPAC::Parser