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 return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
300 return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
303 save_into_lookup($e[3],$e[5],'$key', $e[7] $e[8] );
306 $log->debug("create: $create");
308 # save code to create this lookup
309 $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) } .= $create;
310 $self->{_lookup_create_key}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) }++;
313 if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
314 $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
317 # save this dependency
318 $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
321 $e[8]->insert_after( $e[8]->clone );
322 $e[8]->insert_after( $e[7]->clone );
323 $e[8]->insert_after( $e[6]->clone );
327 $e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );
331 $log->debug(">>> ", $Element->snext_sibling);
334 my $normalize_source = $Document->serialize;
335 $log->debug("create: ", dump($self->{_lookup_create}) );
336 $log->debug("normalize: $normalize_source");
338 $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
340 if ($self->{debug}) {
341 my $Dumper = PPI::Dumper->new( $Document );
345 $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
353 Strip single or double quotes around value
360 my $v = shift || return;
368 Return C<name> value if HASH or arg if scalar
375 my $input = shift || return;
376 if (ref($input) eq 'HASH') {
377 die "can't find 'name' value in ", dump($input) unless defined($input->{name});
378 return $input->{name};
387 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
389 =head1 COPYRIGHT & LICENSE
391 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
393 This program is free software; you can redistribute it and/or modify it
394 under the same terms as Perl itself.
398 1; # End of WebPAC::Parser