1 package WebPAC::Parser;
6 use base qw/WebPAC::Common WebPAC::Normalize/;
10 use Data::Dump qw/dump/;
16 WebPAC::Parser - parse perl normalization configuration files and mungle it
24 our $VERSION = '0.01';
34 Create new parser object.
36 my $parser = new WebPAC::Parser(
37 config => new WebPAC::Config(),
38 base_path => '/optional/path/to/conf',
48 my $log = $self->_get_logger();
50 $log->logdie("config isn't WebPAC::Config") unless ($self->{config} && $self->{config}->isa('WebPAC::Config'));
52 $log->logdie("can't iterate_inputs over this config object") unless ($self->{config}->can('iterate_inputs'));
56 $self->{config}->iterate_inputs( sub {
58 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 $log->debug("adding $path to parser [",length($s)," bytes]");
66 $log->debug("collected ", length($source), " bytes of source");
68 $self->{source} = $source;
70 $self ? return $self : return undef;
80 my $log = $self->_get_logger();
82 $log->logdie('no source found in object') unless ($self->{source});
84 my $Document = PPI::Document->new( \$self->{source} ) || $log->logdie("can't parse source:\n", $self->{source});
86 $Document->prune('PPI::Token::Whitespace');
87 #$Document->prune('PPI::Token::Operator');
89 # Find all the named subroutines
93 $Document->find( sub {
94 my ($Document,$Element) = @_;
96 $Element->isa('PPI::Token::Word') or return '';
97 $Element->content eq 'lookup' or return '';
99 $log->debug("expansion: ", $Element->snext_sibling);
101 my $args = $Element->snext_sibling;
103 my @e = $args->child(0)->elements;
104 $log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
106 if ($log->is_debug) {
107 my $report = "found " . scalar @e . " elements:\n";
109 foreach my $i ( 0 .. $#e ) {
110 $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
113 $log->debug($report);
116 my $key_element = $e[8]->clone;
118 $log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
120 $log->debug("key part: ", $key_element);
124 $key_element->find( sub {
125 my $e = $_[1] || die "no element?";
126 $e->isa('PPI::Token::Word') or return '';
127 $e->content eq 'rec' or return '';
129 my $kf = $e->snext_sibling;
131 $log->debug("key fragment = $kf");
134 $log->logdie("can't eval { $kf }: $@") if ($@);
139 my $key = join('-', @key ) || $log->logdie("no key found!");
141 $log->debug("key = $key");
144 $coderef = ' . $e[7] . $e[8] . ';
145 foreach my $v ($coderef->()) {
146 next unless (defined($v) && $v ne \'\');
147 push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;
151 $log->debug("create: $create");
153 $create =~ s/\s+/ /gs;
154 $eval_create->{ $e[3] }->{ $e[5] } .= $create;
157 $e[8]->insert_after( $e[8]->clone );
158 $e[8]->insert_after( $e[7]->clone );
159 $e[8]->insert_after( $e[6]->clone );
163 $e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );
167 $log->debug(">>> ", $Element->snext_sibling);
170 $log->info("create: ", dump($eval_create) );
171 $log->info("lookup: ", $Document->serialize );
173 if ($self->{debug}) {
174 my $Dumper = PPI::Dumper->new( $Document );
183 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
185 =head1 COPYRIGHT & LICENSE
187 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
189 This program is free software; you can redistribute it and/or modify it
190 under the same terms as Perl itself.
194 1; # End of WebPAC::Parser