git.rot13.org Git - webpac2/blob - lib/WebPAC/Parser.pm

   1 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 Version 0.02
  21
  22 =cut
  23
  24 our $VERSION = '0.02';
  25
  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                 my ($input, $database) = @_;
  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                 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                 $source .= $s;
  65                 $self->{valid_inputs}->{$database}->{$input_name}++;
  66         } );
  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         $log->debug("valid_inputs = ", dump( $self->{valid_inputs} ));
  87
  88         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
  97         $Document->find( sub {
  98                         my ($Document,$Element) = @_;
  99
 100                         $Element->isa('PPI::Token::Word') or return '';
 101                         $Element->content eq 'lookup' or return '';
 102
 103                         $log->debug("expansion: ", $Element->snext_sibling);
 104
 105                         my $args = $Element->snext_sibling;
 106
 107                         my @e = $args->child(0)->elements;
 108                         $log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
 109
 110                         if ($log->is_debug) {
 111                                 my $report = "found " . scalar @e . " elements:\n";
 112
 113                                 foreach my $i ( 0 .. $#e ) {
 114                                         $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
 115                                 }
 116
 117                                 $log->debug($report);
 118                         }
 119
 120                         my $key_element = $e[8]->clone;
 121
 122                         $log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
 123
 124                         $log->debug("key part: ", $key_element);
 125
 126                         my @key;
 127
 128                         $key_element->find( sub {
 129                                 my $e = $_[1] || die "no element?";
 130                                 $e->isa('PPI::Token::Word') or return '';
 131                                 $e->content eq 'rec' or return '';
 132
 133                                 my $kf = $e->snext_sibling;
 134
 135                                 $log->debug("key fragment = $kf");
 136
 137                                 push @key, eval $kf;
 138                                 $log->logdie("can't eval { $kf }: $@") if ($@);
 139
 140                                 return 1;
 141                         });
 142
 143                         my $key = join('-', @key ) || $log->logdie("no key found!");
 144
 145                         $log->debug("key = $key");
 146
 147                         my $create = '
 148                                 $coderef = ' . $e[7] . $e[8] . ';
 149                                 foreach my $v ($coderef->()) {
 150                                         next unless (defined($v) && $v ne \'\');
 151                                         push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;
 152                                 }
 153                         ';
 154
 155                         $log->debug("create: $create");
 156
 157                         $log->logdie("invalid database $e[3]" ) unless $self->valid_database( $e[3] );
 158                         $log->logdie("invalid input $e[5] of database $e[3]", ) unless $self->valid_database_input( $e[3], $e[5] );
 159
 160                         $eval_create->{ $e[3] }->{ $e[5] } .= $create;
 161
 162                         if ($#e < 10) {
 163                                 $e[8]->insert_after( $e[8]->clone );
 164                                 $e[8]->insert_after( $e[7]->clone );
 165                                 $e[8]->insert_after( $e[6]->clone );
 166                         }
 167
 168                         $e[7]->remove;
 169                         $e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );
 170                         $e[8]->remove;
 171
 172
 173                         $log->debug(">>> ", $Element->snext_sibling);
 174         });
 175
 176         $log->info("create: ", dump($eval_create) );
 177         $log->info("lookup: ", $Document->serialize );
 178
 179         if ($self->{debug}) {
 180                 my $Dumper = PPI::Dumper->new( $Document );
 181                 $Dumper->print;
 182         }
 183
 184         return 1;
 185 }
 186
 187 =head2 valid_database
 188
 189   my $ok = $parse->valid_database('key');
 190
 191 =cut
 192
 193 sub valid_database {
 194         my $self = shift;
 195
 196         my $database = shift || return;
 197         $database =~ s/['"]//g;
 198
 199         return defined($self->{valid_inputs}->{$database});
 200 }
 201
 202 =head2 valid_database_input
 203
 204   my $ok = $parse->valid_database('database_key','input_name');
 205
 206 =cut
 207
 208 sub valid_database_input {
 209         my $self = shift;
 210
 211         my ($database,$input) = @_;
 212         $database =~ s/['"]//g;
 213         $input =~ s/['"]//g;
 214
 215         return defined($self->{valid_inputs}->{$database}->{$input});
 216 }
 217
 218 =head1 AUTHOR
 219
 220 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 221
 222 =head1 COPYRIGHT & LICENSE
 223
 224 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 225
 226 This program is free software; you can redistribute it and/or modify it
 227 under the same terms as Perl itself.
 228
 229 =cut
 230
 231 1; # End of WebPAC::Parser