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.04

=cut

our $VERSION = '0.04';

=head1 SYNOPSIS

This module will parse L<WebPAC::Normalize/lookup> directives and generate source
to produce lookups and normalization.

It's written using L<PPI>, pure-perl parser for perl and heavily influenced by
reading about LISP. It might be a bit over-the board, but at least it removed
separate configuration files for lookups.

This is experimental code, but it replaces all older formats which where,
at one point in time, available in WebPAC.

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

        my @lookups;

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

                $log->debug("database: $database input = ", dump($input));

                foreach my $normalize (@{ $input->{normalize} }) {

                        my $path = $normalize->{path};
                        return unless($path);
                        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($input) || $log->logdie("can't deduce name of input: ", dump( $input ));

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

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

                        push @lookups, sub {
                                $self->parse_lookups( $database, $input_name, $full, $s );
                        };

                        $nr++;
                }
        } );

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

        # parse all lookups
        $_->() foreach (@lookups);

        return $nr;
}

=head2 parse_lookups

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

Called for each normalize source in each input by L</new>

It will report invalid databases and inputs in error log after parsing.

=cut

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

        $input = _input_name($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 );

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

        $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");

        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

        $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] );

                        # save code to create this lookup
                        $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) } .= $create;


                        if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
                                $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
                        }

                        # save this dependency
                        $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;

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

        my $normalize_source = $Document->serialize;
        $log->debug("create: ", dump($self->{_lookup_create}) );
        $log->debug("normalize: $normalize_source");

        $self->{_normalize_source}->{$database}->{$input} = $normalize_source;

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

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

        return 1;
}


=head2 lookup_create_rules

  my $source = $parser->lookup_create_rules($database, $input);

=cut

sub lookup_create_rules {
        my $self = shift;
        my ($database,$input) = @_;
        return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
}

=head2 valid_database

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

=cut

sub valid_database {
        my $self = shift;

        my $database = shift || return;

        return defined($self->{valid_inputs}->{ _q($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) = @_;
        return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
}

=head2 depends

Return all databases and inputs on which specified one depends

  $depends_on = $parser->depends('database','input');

=cut

sub depends {
        my $self = shift;
        my ($database,$input) = @_;
        $self->_get_logger->debug("depends($database,$input)");
        return unless (
                defined( $self->{depends}->{ _q($database) } ) &&
                defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
        );
        return $self->{depends}->{ _q($database) }->{ _q($input) };
}

=head1 PRIVATE

=head2 _q

Strip single or double quotes around value

  _q(qq/'foo'/) -> foo

=cut

sub _q {
        my $v = shift || return;
        $v =~ s/^['"]*//g;
        $v =~ s/['"]*$//g;
        return $v;
}

=head2 _input_name

Return C<name> value if HASH or arg if scalar

  _input_name($input)

=cut

sub _input_name {
        my $input = shift || return;
        if (ref($input) eq 'HASH') {
                die "can't find 'name' value in ", dump($input) unless defined($input->{name});
                return $input->{name};
        } else {
                return $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	698	Version 0.04
21	dpavlin	686
22			=cut
23
24	dpavlin	698	our $VERSION = '0.04';
25	dpavlin	686
26			=head1 SYNOPSIS
27
28	dpavlin	698	This module will parse L<WebPAC::Normalize/lookup> directives and generate source
29			to produce lookups and normalization.
30
31			It's written using L<PPI>, pure-perl parser for perl and heavily influenced by
32			reading about LISP. It might be a bit over-the board, but at least it removed
33			separate configuration files for lookups.
34
35			This is experimental code, but it replaces all older formats which where,
36			at one point in time, available in WebPAC.
37
38	dpavlin	686	FIXME
39
40			=head1 FUNCTIONS
41
42			=head2 new
43
44			Create new parser object.
45
46			my $parser = new WebPAC::Parser(
47			config => new WebPAC::Config(),
48			base_path => '/optional/path/to/conf',
49			);
50
51			=cut
52
53			sub new {
54			my $class = shift;
55			my $self = {@_};
56			bless($self, $class);
57
58			my $log = $self->_get_logger();
59
60			$log->logdie("config isn't WebPAC::Config") unless ($self->{config} && $self->{config}->isa('WebPAC::Config'));
61
62			$log->logdie("can't iterate_inputs over this config object") unless ($self->{config}->can('iterate_inputs'));
63
64	dpavlin	691	$self->read_sources;
65	dpavlin	686
66	dpavlin	691	$self ? return $self : return undef;
67			}
68
69			=head2 read_sources
70
71			my $source_files = $parser->read_sources;
72
73			Called by L</new>.
74
75			=cut
76
77			sub read_sources {
78			my $self = shift;
79
80			my $log = $self->_get_logger();
81
82			my $nr = 0;
83
84	dpavlin	701	my @lookups;
85
86	dpavlin	691	$self->{config}->iterate_inputs( sub {
87			my ($input, $database) = @_;
88
89	dpavlin	699	$log->debug("database: $database input = ", dump($input));
90
91	dpavlin	701	foreach my $normalize (@{ $input->{normalize} }) {
92	dpavlin	691
93	dpavlin	698	my $path = $normalize->{path};
94			return unless($path);
95			my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
96	dpavlin	691
97	dpavlin	698	$log->logdie("normalization input $full doesn't exist") unless (-e $full);
98	dpavlin	691
99	dpavlin	698	my $s = read_file( $full ) \|\| $log->logdie("can't read $full: $!");
100	dpavlin	691
101	dpavlin	698	my $input_name = _input_name($input) \|\| $log->logdie("can't deduce name of input: ", dump( $input ));
102	dpavlin	691
103	dpavlin	698	$log->debug("$database/$input_name: adding $path");
104
105	dpavlin	701	$self->{valid_inputs}->{$database}->{$input_name}++;
106	dpavlin	698
107	dpavlin	701	push @lookups, sub {
108			$self->parse_lookups( $database, $input_name, $full, $s );
109			};
110	dpavlin	698
111			$nr++;
112			}
113	dpavlin	686	} );
114
115	dpavlin	691	$log->debug("found $nr source files");
116	dpavlin	686
117	dpavlin	701	# parse all lookups
118			$_->() foreach (@lookups);
119
120	dpavlin	691	return $nr;
121	dpavlin	686	}
122
123	dpavlin	692	=head2 parse_lookups
124	dpavlin	686
125	dpavlin	701	$parser->parse_lookups($database,$input,$path,$source);
126	dpavlin	691
127	dpavlin	701	Called for each normalize source in each input by L</new>
128	dpavlin	698
129			It will report invalid databases and inputs in error log after parsing.
130
131	dpavlin	686	=cut
132
133	dpavlin	691	sub parse_lookups {
134	dpavlin	686	my $self = shift;
135	dpavlin	701	my ($database, $input, $path, $source) = @_;
136	dpavlin	686
137	dpavlin	698	$input = _input_name($input);
138
139	dpavlin	686	my $log = $self->_get_logger();
140
141	dpavlin	691	$log->logdie("invalid database $database" ) unless $self->valid_database( $database );
142			$log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
143	dpavlin	686
144	dpavlin	691	$log->logdie("no source found for database $database input $input path $path") unless ($source);
145	dpavlin	686
146	dpavlin	701	$log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
147	dpavlin	691
148			my $Document = PPI::Document->new( \$source ) \|\| $log->logdie("can't parse source:\n", $self->{source});
149
150	dpavlin	686	$Document->prune('PPI::Token::Whitespace');
151			#$Document->prune('PPI::Token::Operator');
152
153			# Find all the named subroutines
154
155	dpavlin	691	$self->{_lookup_errors} = ();
156	dpavlin	686
157	dpavlin	691	sub _lookup_error {
158			my $self = shift;
159			my $msg = shift;
160			$self->_get_logger->logconfess("error without message?") unless ($msg);
161			push @{ $self->{_lookup_errors} }, $msg;
162	dpavlin	690	return '';
163			}
164
165	dpavlin	686	$Document->find( sub {
166			my ($Document,$Element) = @_;
167
168			$Element->isa('PPI::Token::Word') or return '';
169			$Element->content eq 'lookup' or return '';
170
171	dpavlin	687	$log->debug("expansion: ", $Element->snext_sibling);
172	dpavlin	686
173			my $args = $Element->snext_sibling;
174
175			my @e = $args->child(0)->elements;
176	dpavlin	687	$log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
177	dpavlin	686
178	dpavlin	687	if ($log->is_debug) {
179			my $report = "found " . scalar @e . " elements:\n";
180	dpavlin	686
181	dpavlin	687	foreach my $i ( 0 .. $#e ) {
182			$report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] \|\| 'undef' ), $e[$i]->class );
183			}
184
185			$log->debug($report);
186	dpavlin	686	}
187
188			my $key_element = $e[8]->clone;
189
190	dpavlin	687	$log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
191	dpavlin	686
192	dpavlin	687	$log->debug("key part: ", $key_element);
193	dpavlin	686
194			my @key;
195
196			$key_element->find( sub {
197			my $e = $_[1] \|\| die "no element?";
198			$e->isa('PPI::Token::Word') or return '';
199			$e->content eq 'rec' or return '';
200
201			my $kf = $e->snext_sibling;
202
203	dpavlin	687	$log->debug("key fragment = $kf");
204	dpavlin	686
205			push @key, eval $kf;
206	dpavlin	687	$log->logdie("can't eval { $kf }: $@") if ($@);
207	dpavlin	686
208			return 1;
209			});
210
211	dpavlin	687	my $key = join('-', @key ) \|\| $log->logdie("no key found!");
212	dpavlin	686
213	dpavlin	687	$log->debug("key = $key");
214	dpavlin	686
215			my $create = '
216			$coderef = ' . $e[7] . $e[8] . ';
217			foreach my $v ($coderef->()) {
218			next unless (defined($v) && $v ne \'\');
219			push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;
220			}
221			';
222
223	dpavlin	687	$log->debug("create: $create");
224	dpavlin	686
225	dpavlin	691	return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
226			return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
227	dpavlin	689
228	dpavlin	698	# save code to create this lookup
229			$self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) } .= $create;
230	dpavlin	686
231	dpavlin	698
232	dpavlin	702	if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
233			$log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
234	dpavlin	698	}
235
236			# save this dependency
237	dpavlin	702	$self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
238	dpavlin	698
239	dpavlin	686	if ($#e < 10) {
240			$e[8]->insert_after( $e[8]->clone );
241			$e[8]->insert_after( $e[7]->clone );
242			$e[8]->insert_after( $e[6]->clone );
243			}
244
245			$e[7]->remove;
246			$e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );
247			$e[8]->remove;
248
249
250	dpavlin	687	$log->debug(">>> ", $Element->snext_sibling);
251	dpavlin	686	});
252
253	dpavlin	693	my $normalize_source = $Document->serialize;
254	dpavlin	692	$log->debug("create: ", dump($self->{_lookup_create}) );
255	dpavlin	693	$log->debug("normalize: $normalize_source");
256	dpavlin	686
257	dpavlin	693	$self->{_normalize_source}->{$database}->{$input} = $normalize_source;
258	dpavlin	692
259	dpavlin	687	if ($self->{debug}) {
260			my $Dumper = PPI::Dumper->new( $Document );
261			$Dumper->print;
262			}
263	dpavlin	686
264	dpavlin	692	$log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
265	dpavlin	690
266	dpavlin	687	return 1;
267	dpavlin	686	}
268
269	dpavlin	692
270	dpavlin	698	=head2 lookup_create_rules
271	dpavlin	692
272	dpavlin	698	my $source = $parser->lookup_create_rules($database, $input);
273
274	dpavlin	692	=cut
275
276	dpavlin	698	sub lookup_create_rules {
277	dpavlin	692	my $self = shift;
278	dpavlin	698	my ($database,$input) = @_;
279			return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
280	dpavlin	692	}
281
282	dpavlin	689	=head2 valid_database
283
284			my $ok = $parse->valid_database('key');
285
286			=cut
287
288			sub valid_database {
289			my $self = shift;
290
291			my $database = shift \|\| return;
292
293	dpavlin	698	return defined($self->{valid_inputs}->{ _q($database) });
294	dpavlin	689	}
295
296			=head2 valid_database_input
297
298			my $ok = $parse->valid_database('database_key','input_name');
299
300			=cut
301
302			sub valid_database_input {
303			my $self = shift;
304
305			my ($database,$input) = @_;
306	dpavlin	698	return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
307			}
308	dpavlin	689
309	dpavlin	698	=head2 depends
310
311			Return all databases and inputs on which specified one depends
312
313			$depends_on = $parser->depends('database','input');
314
315			=cut
316
317			sub depends {
318			my $self = shift;
319			my ($database,$input) = @_;
320			$self->_get_logger->debug("depends($database,$input)");
321	dpavlin	699	return unless (
322			defined( $self->{depends}->{ _q($database) } ) &&
323			defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
324			);
325	dpavlin	698	return $self->{depends}->{ _q($database) }->{ _q($input) };
326	dpavlin	689	}
327
328	dpavlin	698	=head1 PRIVATE
329
330			=head2 _q
331
332			Strip single or double quotes around value
333
334			_q(qq/'foo'/) -> foo
335
336			=cut
337
338			sub _q {
339			my $v = shift \|\| return;
340			$v =~ s/^['"]*//g;
341			$v =~ s/['"]*$//g;
342			return $v;
343			}
344
345			=head2 _input_name
346
347			Return C<name> value if HASH or arg if scalar
348
349			_input_name($input)
350
351			=cut
352
353			sub _input_name {
354			my $input = shift \|\| return;
355			if (ref($input) eq 'HASH') {
356			die "can't find 'name' value in ", dump($input) unless defined($input->{name});
357			return $input->{name};
358			} else {
359			return $input;
360			}
361			}
362
363
364	dpavlin	686	=head1 AUTHOR
365
366			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
367
368			=head1 COPYRIGHT & LICENSE
369
370			Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
371
372			This program is free software; you can redistribute it and/or modify it
373			under the same terms as Perl itself.
374
375			=cut
376
377			1; # End of WebPAC::Parser