lib/WebPAC/Parser.pm

package WebPAC::Parser;

use warnings;
use strict;

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

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


=head1 NAME

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

=head1 VERSION

Version 0.02

=cut

our $VERSION = '0.02';

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

        my $source;

        $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 to parser [",length($s)," bytes]");
                $source .= $s;
                $self->{valid_inputs}->{$database}->{$input_name}++;
        } );

        $log->debug("collected ", length($source), " bytes of source");

        $self->{source} = $source;

        $self ? return $self : return undef;
}

=head2 parse

=cut

sub parse {
        my $self = shift;

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

        $log->logdie('no source found in object') unless ($self->{source});

        $log->debug("valid_inputs = ", dump( $self->{valid_inputs} ));

        my $Document = PPI::Document->new( \$self->{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;
        my @errors;

        sub error {
                my $msg = shift || $log->logconfess("error without message?");
                push @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 error("invalid database $e[3]" ) unless $self->valid_database( $e[3] );
                        return error("invalid input $e[5] of database $e[3]", ) 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",@errors) ) if (@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			use base qw/WebPAC::Common WebPAC::Normalize/;
7
8			use PPI;
9			use PPI::Dumper;
10			use Data::Dump qw/dump/;
11			use File::Slurp;
12
13
14			=head1 NAME
15
16			WebPAC::Parser - parse perl normalization configuration files and mungle it
17
18			=head1 VERSION
19
20	dpavlin	689	Version 0.02
21	dpavlin	686
22			=cut
23
24	dpavlin	689	our $VERSION = '0.02';
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			my $source;
55
56			$self->{config}->iterate_inputs( sub {
57	dpavlin	689	my ($input, $database) = @_;
58	dpavlin	686	my $path = $input->{normalize}->{path} \|\| return;
59			my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
60			$log->logdie("normalization input $full doesn't exist") unless (-e $full);
61			my $s = read_file( $full ) \|\| $log->logdie("can't read $full: $!");
62	dpavlin	689	my $input_name = $input->{name} \|\| $log->logdie("can't deduce name of input: ", dump( $input ));
63			$log->debug("$database/$input_name: adding $path to parser [",length($s)," bytes]");
64	dpavlin	686	$source .= $s;
65	dpavlin	689	$self->{valid_inputs}->{$database}->{$input_name}++;
66	dpavlin	686	} );
67
68			$log->debug("collected ", length($source), " bytes of source");
69
70			$self->{source} = $source;
71
72			$self ? return $self : return undef;
73			}
74
75			=head2 parse
76
77			=cut
78
79			sub parse {
80			my $self = shift;
81
82			my $log = $self->_get_logger();
83
84			$log->logdie('no source found in object') unless ($self->{source});
85
86	dpavlin	689	$log->debug("valid_inputs = ", dump( $self->{valid_inputs} ));
87
88	dpavlin	686	my $Document = PPI::Document->new( \$self->{source} ) \|\| $log->logdie("can't parse source:\n", $self->{source});
89
90			$Document->prune('PPI::Token::Whitespace');
91			#$Document->prune('PPI::Token::Operator');
92
93			# Find all the named subroutines
94
95			my $eval_create;
96	dpavlin	690	my @errors;
97	dpavlin	686
98	dpavlin	690	sub error {
99			my $msg = shift \|\| $log->logconfess("error without message?");
100			push @errors, $msg;
101			return '';
102			}
103
104	dpavlin	686	$Document->find( sub {
105			my ($Document,$Element) = @_;
106
107			$Element->isa('PPI::Token::Word') or return '';
108			$Element->content eq 'lookup' or return '';
109
110	dpavlin	687	$log->debug("expansion: ", $Element->snext_sibling);
111	dpavlin	686
112			my $args = $Element->snext_sibling;
113
114			my @e = $args->child(0)->elements;
115	dpavlin	687	$log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
116	dpavlin	686
117	dpavlin	687	if ($log->is_debug) {
118			my $report = "found " . scalar @e . " elements:\n";
119	dpavlin	686
120	dpavlin	687	foreach my $i ( 0 .. $#e ) {
121			$report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] \|\| 'undef' ), $e[$i]->class );
122			}
123
124			$log->debug($report);
125	dpavlin	686	}
126
127			my $key_element = $e[8]->clone;
128
129	dpavlin	687	$log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
130	dpavlin	686
131	dpavlin	687	$log->debug("key part: ", $key_element);
132	dpavlin	686
133			my @key;
134
135			$key_element->find( sub {
136			my $e = $_[1] \|\| die "no element?";
137			$e->isa('PPI::Token::Word') or return '';
138			$e->content eq 'rec' or return '';
139
140			my $kf = $e->snext_sibling;
141
142	dpavlin	687	$log->debug("key fragment = $kf");
143	dpavlin	686
144			push @key, eval $kf;
145	dpavlin	687	$log->logdie("can't eval { $kf }: $@") if ($@);
146	dpavlin	686
147			return 1;
148			});
149
150	dpavlin	687	my $key = join('-', @key ) \|\| $log->logdie("no key found!");
151	dpavlin	686
152	dpavlin	687	$log->debug("key = $key");
153	dpavlin	686
154			my $create = '
155			$coderef = ' . $e[7] . $e[8] . ';
156			foreach my $v ($coderef->()) {
157			next unless (defined($v) && $v ne \'\');
158			push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;
159			}
160			';
161
162	dpavlin	687	$log->debug("create: $create");
163	dpavlin	686
164	dpavlin	690	return error("invalid database $e[3]" ) unless $self->valid_database( $e[3] );
165			return error("invalid input $e[5] of database $e[3]", ) unless $self->valid_database_input( $e[3], $e[5] );
166	dpavlin	689
167	dpavlin	686	$eval_create->{ $e[3] }->{ $e[5] } .= $create;
168
169			if ($#e < 10) {
170			$e[8]->insert_after( $e[8]->clone );
171			$e[8]->insert_after( $e[7]->clone );
172			$e[8]->insert_after( $e[6]->clone );
173			}
174
175			$e[7]->remove;
176			$e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );
177			$e[8]->remove;
178
179
180	dpavlin	687	$log->debug(">>> ", $Element->snext_sibling);
181	dpavlin	686	});
182
183	dpavlin	687	$log->info("create: ", dump($eval_create) );
184			$log->info("lookup: ", $Document->serialize );
185	dpavlin	686
186	dpavlin	687	if ($self->{debug}) {
187			my $Dumper = PPI::Dumper->new( $Document );
188			$Dumper->print;
189			}
190	dpavlin	686
191	dpavlin	690	$log->error("Parser errors: ", join("\n",@errors) ) if (@errors);
192
193	dpavlin	687	return 1;
194	dpavlin	686	}
195
196	dpavlin	689	=head2 valid_database
197
198			my $ok = $parse->valid_database('key');
199
200			=cut
201
202			sub valid_database {
203			my $self = shift;
204
205			my $database = shift \|\| return;
206			$database =~ s/['"]//g;
207
208			return defined($self->{valid_inputs}->{$database});
209			}
210
211			=head2 valid_database_input
212
213			my $ok = $parse->valid_database('database_key','input_name');
214
215			=cut
216
217			sub valid_database_input {
218			my $self = shift;
219
220			my ($database,$input) = @_;
221			$database =~ s/['"]//g;
222			$input =~ s/['"]//g;
223
224			return defined($self->{valid_inputs}->{$database}->{$input});
225			}
226
227	dpavlin	686	=head1 AUTHOR
228
229			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
230
231			=head1 COPYRIGHT & LICENSE
232
233			Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
234
235			This program is free software; you can redistribute it and/or modify it
236			under the same terms as Perl itself.
237
238			=cut
239
240			1; # End of WebPAC::Parser