1 package WebPAC::Parser;
9 use Data::Dump qw/dump/;
12 use base qw/WebPAC::Common/;
16 WebPAC::Parser - parse perl normalization configuration files and mungle it
24 our $VERSION = '0.05';
28 This module will parse L<WebPAC::Normalize/lookup> directives and generate source
29 to produce lookups and normalization.
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.
35 This is experimental code, but it replaces all older formats which where,
36 at one point in time, available in WebPAC.
44 Create new parser object.
46 my $parser = new WebPAC::Parser(
47 config => new WebPAC::Config(),
48 base_path => '/optional/path/to/conf',
58 my $log = $self->_get_logger();
60 $log->logdie("config isn't WebPAC::Config") unless ($self->{config} && $self->{config}->isa('WebPAC::Config'));
62 $log->logdie("can't iterate_inputs over this config object") unless ($self->{config}->can('iterate_inputs'));
66 $self ? return $self : return undef;
71 my $ok = $parse->valid_database('key');
78 my $database = shift || return;
80 return defined($self->{valid_inputs}->{ _q($database) });
83 =head2 valid_database_input
85 my $ok = $parse->valid_database('database_key','input_name');
89 sub valid_database_input {
91 my ($database,$input) = @_;
92 $input = _input_name($input);
93 return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
98 Return all databases and inputs on which specified one depends
100 $depends_on = $parser->depends('database','input');
106 my ($database,$input) = @_;
107 $input = _input_name($input);
108 $self->_get_logger->debug("depends($database,$input)");
110 defined( $self->{depends}->{ _q($database) } ) &&
111 defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
113 return $self->{depends}->{ _q($database) }->{ _q($input) };
116 =head2 have_lookup_create
118 my @keys = $parser->have_lookup_create($database, $input);
122 sub have_lookup_create {
124 my ($database,$input) = @_;
125 $input = _input_name($input);
127 defined( $self->{_lookup_create_key}->{ _q($database) } ) &&
128 defined( $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } )
130 return keys %{ $self->{_lookup_create_key}->{ _q($database) }->{ _q($input) } };
134 =head2 lookup_create_rules
136 my $source = $parser->lookup_create_rules($database, $input);
140 sub lookup_create_rules {
142 my ($database,$input) = @_;
143 $input = _input_name($input);
145 defined( $self->{_lookup_create}->{ _q($database) } ) &&
146 defined( $self->{_lookup_create}->{ _q($database) }->{ _q($input) } )
148 return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
155 my $source_files = $parser->_read_sources;
164 my $log = $self->_get_logger();
170 $self->{config}->iterate_inputs( sub {
171 my ($input, $database) = @_;
173 $log->debug("database: $database input = ", dump($input));
175 foreach my $normalize (@{ $input->{normalize} }) {
177 my $path = $normalize->{path};
178 return unless($path);
179 my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
181 $log->logdie("normalization input $full doesn't exist") unless (-e $full);
183 my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
185 my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
187 $log->debug("$database/$input_name: adding $path");
189 $self->{valid_inputs}->{$database}->{$input_name}++;
192 $self->_parse_lookups( $database, $input_name, $full, $s );
199 $log->debug("found $nr source files");
202 $_->() foreach (@lookups);
207 =head2 _parse_lookups
209 $parser->_parse_lookups($database,$input,$path,$source);
211 Called for each normalize source (rules) in each input by L</_read_sources>
213 It will report invalid databases and inputs in error log after parsing.
219 my ($database, $input, $path, $source) = @_;
221 $input = _input_name($input);
223 my $log = $self->_get_logger();
225 $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
226 $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
228 $log->logdie("no source found for database $database input $input path $path") unless ($source);
230 $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
232 my $Document = PPI::Document->new( \$source ) || $log->logdie("can't parse source:\n", $self->{source});
234 $Document->prune('PPI::Token::Whitespace');
235 #$Document->prune('PPI::Token::Operator');
237 # Find all the named subroutines
239 $self->{_lookup_errors} = ();
244 $self->_get_logger->logconfess("error without message?") unless ($msg);
245 push @{ $self->{_lookup_errors} }, $msg;
249 $Document->find( sub {
250 my ($Document,$Element) = @_;
252 $Element->isa('PPI::Token::Word') or return '';
253 $Element->content eq 'lookup' or return '';
255 $log->debug("expansion: ", $Element->snext_sibling);
257 my $args = $Element->snext_sibling;
259 my @e = $args->child(0)->elements;
260 $log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
262 if ($log->is_debug) {
263 my $report = "found " . scalar @e . " elements:\n";
265 foreach my $i ( 0 .. $#e ) {
266 $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
269 $log->debug($report);
272 my $key_element = $e[8]->clone;
274 $log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
276 $log->debug("key part: ", $key_element);
280 $key_element->find( sub {
281 my $e = $_[1] || die "no element?";
282 $e->isa('PPI::Token::Word') or return '';
283 $e->content eq 'rec' or return '';
285 my $kf = $e->snext_sibling;
287 $log->debug("key fragment = $kf");
290 $log->logdie("can't eval { $kf }: $@") if ($@);
295 my $key = join('-', @key ) || $log->logdie("no key found!");
297 $log->debug("key = $key");
299 my $create = "save_into_lookup('$key', $e[7] $e[8] );\n";
301 $log->debug("create: $create");
303 return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
304 return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
306 # save code to create this lookup
307 $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) } .= $create;
308 $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
311 if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
312 $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
315 # save this dependency
316 $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
319 $e[8]->insert_after( $e[8]->clone );
320 $e[8]->insert_after( $e[7]->clone );
321 $e[8]->insert_after( $e[6]->clone );
325 $e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );
329 $log->debug(">>> ", $Element->snext_sibling);
332 my $normalize_source = $Document->serialize;
333 $log->debug("create: ", dump($self->{_lookup_create}) );
334 $log->debug("normalize: $normalize_source");
336 $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
338 if ($self->{debug}) {
339 my $Dumper = PPI::Dumper->new( $Document );
343 $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
351 Strip single or double quotes around value
358 my $v = shift || return;
366 Return C<name> value if HASH or arg if scalar
373 my $input = shift || return;
374 if (ref($input) eq 'HASH') {
375 die "can't find 'name' value in ", dump($input) unless defined($input->{name});
376 return $input->{name};
385 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
387 =head1 COPYRIGHT & LICENSE
389 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
391 This program is free software; you can redistribute it and/or modify it
392 under the same terms as Perl itself.
396 1; # End of WebPAC::Parser