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

   1 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 use base qw/WebPAC::Common WebPAC::Normalize/;
  13
  14 =head1 NAME
  15
  16 WebPAC::Parser - parse perl normalization configuration files and mungle it
  17
  18 =head1 VERSION
  19
  20 Version 0.03
  21
  22 =cut
  23
  24 our $VERSION = '0.03';
  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         $self->read_sources;
  55
  56         $self->{config}->iterate_inputs( sub {
  57                 my ($input, $database) = @_;
  58                 return unless $self->valid_database_input($database, $input->{name});
  59                 $self->parse_lookups($database,$input->{name});
  60         } );
  61
  62         $self ? return $self : return undef;
  63 }
  64
  65 =head2 read_sources
  66
  67   my $source_files = $parser->read_sources;
  68
  69 Called by L</new>.
  70
  71 =cut
  72
  73 sub read_sources {
  74         my $self = shift;
  75
  76         my $log = $self->_get_logger();
  77
  78         my $nr = 0;
  79
  80         $self->{config}->iterate_inputs( sub {
  81                 my ($input, $database) = @_;
  82
  83                 my $path = $input->{normalize}->{path} || return;
  84                 my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
  85
  86                 $log->logdie("normalization input $full doesn't exist") unless (-e $full);
  87
  88                 my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
  89
  90                 my $input_name = $input->{name} || $log->logdie("can't deduce name of input: ", dump( $input ));
  91
  92                 $log->debug("$database/$input_name: adding $path");
  93
  94                 $self->{valid_inputs}->{$database}->{$input_name} = {
  95                         source => $s,
  96                         path => $full,
  97                         usage => 0,
  98                 } unless defined($self->{valid_inputs}->{$database}->{$input_name});
  99
 100                 $self->{valid_inputs}->{$database}->{$input_name}->{usage}++;
 101
 102                 $nr++;
 103         } );
 104
 105         $log->debug("found $nr source files");
 106
 107         return $nr;
 108 }
 109
 110 =head2 parse_lookups
 111
 112   $parser->parse_lookups($database,$input);
 113
 114 =cut
 115
 116 sub parse_lookups {
 117         my $self = shift;
 118         my ($database, $input) = @_;
 119
 120         my $log = $self->_get_logger();
 121
 122         $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
 123         $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
 124
 125         my $source = $self->{valid_inputs}->{$database}->{$input}->{source};
 126         my $path = $self->{valid_inputs}->{$database}->{$input}->{path};
 127
 128         $log->logdie("no source found for database $database input $input path $path") unless ($source);
 129
 130         $log->info("parsing lookups for $database/$input from $path");
 131
 132         my $Document = PPI::Document->new( \$source ) || $log->logdie("can't parse source:\n", $self->{source});
 133
 134         $Document->prune('PPI::Token::Whitespace');
 135         #$Document->prune('PPI::Token::Operator');
 136
 137         # Find all the named subroutines
 138
 139         $self->{_lookup_errors} = ();
 140
 141         sub _lookup_error {
 142                 my $self = shift;
 143                 my $msg = shift;
 144                 $self->_get_logger->logconfess("error without message?") unless ($msg);
 145                 push @{ $self->{_lookup_errors} }, $msg;
 146                 return '';
 147         }
 148
 149         $Document->find( sub {
 150                         my ($Document,$Element) = @_;
 151
 152                         $Element->isa('PPI::Token::Word') or return '';
 153                         $Element->content eq 'lookup' or return '';
 154
 155                         $log->debug("expansion: ", $Element->snext_sibling);
 156
 157                         my $args = $Element->snext_sibling;
 158
 159                         my @e = $args->child(0)->elements;
 160                         $log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
 161
 162                         if ($log->is_debug) {
 163                                 my $report = "found " . scalar @e . " elements:\n";
 164
 165                                 foreach my $i ( 0 .. $#e ) {
 166                                         $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
 167                                 }
 168
 169                                 $log->debug($report);
 170                         }
 171
 172                         my $key_element = $e[8]->clone;
 173
 174                         $log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
 175
 176                         $log->debug("key part: ", $key_element);
 177
 178                         my @key;
 179
 180                         $key_element->find( sub {
 181                                 my $e = $_[1] || die "no element?";
 182                                 $e->isa('PPI::Token::Word') or return '';
 183                                 $e->content eq 'rec' or return '';
 184
 185                                 my $kf = $e->snext_sibling;
 186
 187                                 $log->debug("key fragment = $kf");
 188
 189                                 push @key, eval $kf;
 190                                 $log->logdie("can't eval { $kf }: $@") if ($@);
 191
 192                                 return 1;
 193                         });
 194
 195                         my $key = join('-', @key ) || $log->logdie("no key found!");
 196
 197                         $log->debug("key = $key");
 198
 199                         my $create = '
 200                                 $coderef = ' . $e[7] . $e[8] . ';
 201                                 foreach my $v ($coderef->()) {
 202                                         next unless (defined($v) && $v ne \'\');
 203                                         push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;
 204                                 }
 205                         ';
 206
 207                         $log->debug("create: $create");
 208
 209                         return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
 210                         return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
 211
 212                         $self->add_lookup_create( $e[3], $e[5], $create );
 213
 214                         if ($#e < 10) {
 215                                 $e[8]->insert_after( $e[8]->clone );
 216                                 $e[8]->insert_after( $e[7]->clone );
 217                                 $e[8]->insert_after( $e[6]->clone );
 218                         }
 219
 220                         $e[7]->remove;
 221                         $e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );
 222                         $e[8]->remove;
 223
 224
 225                         $log->debug(">>> ", $Element->snext_sibling);
 226         });
 227
 228         my $normalize_source = $Document->serialize;
 229         $log->debug("create: ", dump($self->{_lookup_create}) );
 230         $log->debug("normalize: $normalize_source");
 231
 232         $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
 233
 234         if ($self->{debug}) {
 235                 my $Dumper = PPI::Dumper->new( $Document );
 236                 $Dumper->print;
 237         }
 238
 239         $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
 240
 241         return 1;
 242 }
 243
 244 =head2 add_lookup_create
 245
 246   $parse->add_lookup_create($database,$input,$source);
 247
 248 =cut
 249
 250 sub add_lookup_create {
 251         my $self = shift;
 252         my ($database,$input,$source) = @_;
 253         $self->{_lookup_create}->{$database}->{$input} .= $source;
 254 }
 255
 256
 257 =head2 valid_database
 258
 259   my $ok = $parse->valid_database('key');
 260
 261 =cut
 262
 263 sub valid_database {
 264         my $self = shift;
 265
 266         my $database = shift || return;
 267         $database =~ s/['"]//g;
 268
 269         return defined($self->{valid_inputs}->{$database});
 270 }
 271
 272 =head2 valid_database_input
 273
 274   my $ok = $parse->valid_database('database_key','input_name');
 275
 276 =cut
 277
 278 sub valid_database_input {
 279         my $self = shift;
 280
 281         my ($database,$input) = @_;
 282         $database =~ s/['"]//g;
 283         $input =~ s/['"]//g;
 284
 285         return defined($self->{valid_inputs}->{$database}->{$input});
 286 }
 287
 288 =head1 AUTHOR
 289
 290 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 291
 292 =head1 COPYRIGHT & LICENSE
 293
 294 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 295
 296 This program is free software; you can redistribute it and/or modify it
 297 under the same terms as Perl itself.
 298
 299 =cut
 300
 301 1; # End of WebPAC::Parser