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.04
  21
  22 =cut
  23
  24 our $VERSION = '0.04';
  25
  26 =head1 SYNOPSIS
  27
  28 This module will parse L<WebPAC::Normalize/lookup> directives and generate source
  29 to produce lookups and normalization.
  30
  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.
  34
  35 This is experimental code, but it replaces all older formats which where,
  36 at one point in time, available in WebPAC.
  37
  38 FIXME
  39
  40 =head1 FUNCTIONS
  41
  42 =head2 new
  43
  44 Create new parser object.
  45
  46   my $parser = new WebPAC::Parser(
  47         config => new WebPAC::Config(),
  48         base_path => '/optional/path/to/conf',
  49   );
  50
  51 =cut
  52
  53 sub new {
  54         my $class = shift;
  55         my $self = {@_};
  56         bless($self, $class);
  57
  58         my $log = $self->_get_logger();
  59
  60         $log->logdie("config isn't WebPAC::Config") unless ($self->{config} && $self->{config}->isa('WebPAC::Config'));
  61
  62         $log->logdie("can't iterate_inputs over this config object") unless ($self->{config}->can('iterate_inputs'));
  63
  64         $self->read_sources;
  65
  66         $self ? return $self : return undef;
  67 }
  68
  69 =head2 read_sources
  70
  71   my $source_files = $parser->read_sources;
  72
  73 Called by L</new>.
  74
  75 =cut
  76
  77 sub read_sources {
  78         my $self = shift;
  79
  80         my $log = $self->_get_logger();
  81
  82         my $nr = 0;
  83
  84         my @lookups;
  85
  86         $self->{config}->iterate_inputs( sub {
  87                 my ($input, $database) = @_;
  88
  89                 $log->debug("database: $database input = ", dump($input));
  90
  91                 foreach my $normalize (@{ $input->{normalize} }) {
  92
  93                         my $path = $normalize->{path};
  94                         return unless($path);
  95                         my $full = $self->{base_path} ? $self->{base_path} . '/' . $path : $path;
  96
  97                         $log->logdie("normalization input $full doesn't exist") unless (-e $full);
  98
  99                         my $s = read_file( $full ) || $log->logdie("can't read $full: $!");
 100
 101                         my $input_name = _input_name($input) || $log->logdie("can't deduce name of input: ", dump( $input ));
 102
 103                         $log->debug("$database/$input_name: adding $path");
 104
 105                         $self->{valid_inputs}->{$database}->{$input_name}++;
 106
 107                         push @lookups, sub {
 108                                 $self->parse_lookups( $database, $input_name, $full, $s );
 109                         };
 110
 111                         $nr++;
 112                 }
 113         } );
 114
 115         $log->debug("found $nr source files");
 116
 117         # parse all lookups
 118         $_->() foreach (@lookups);
 119
 120         return $nr;
 121 }
 122
 123 =head2 parse_lookups
 124
 125   $parser->parse_lookups($database,$input,$path,$source);
 126
 127 Called for each normalize source in each input by L</new>
 128
 129 It will report invalid databases and inputs in error log after parsing.
 130
 131 =cut
 132
 133 sub parse_lookups {
 134         my $self = shift;
 135         my ($database, $input, $path, $source) = @_;
 136
 137         $input = _input_name($input);
 138
 139         my $log = $self->_get_logger();
 140
 141         $log->logdie("invalid database $database" ) unless $self->valid_database( $database );
 142         $log->logdie("invalid input $input of database $database", ) unless $self->valid_database_input( $database, $input );
 143
 144         $log->logdie("no source found for database $database input $input path $path") unless ($source);
 145
 146         $log->info("parsing lookups for $database/$input from $path (",length($source)," bytes)");
 147
 148         my $Document = PPI::Document->new( \$source ) || $log->logdie("can't parse source:\n", $self->{source});
 149
 150         $Document->prune('PPI::Token::Whitespace');
 151         #$Document->prune('PPI::Token::Operator');
 152
 153         # Find all the named subroutines
 154
 155         $self->{_lookup_errors} = ();
 156
 157         sub _lookup_error {
 158                 my $self = shift;
 159                 my $msg = shift;
 160                 $self->_get_logger->logconfess("error without message?") unless ($msg);
 161                 push @{ $self->{_lookup_errors} }, $msg;
 162                 return '';
 163         }
 164
 165         $Document->find( sub {
 166                         my ($Document,$Element) = @_;
 167
 168                         $Element->isa('PPI::Token::Word') or return '';
 169                         $Element->content eq 'lookup' or return '';
 170
 171                         $log->debug("expansion: ", $Element->snext_sibling);
 172
 173                         my $args = $Element->snext_sibling;
 174
 175                         my @e = $args->child(0)->elements;
 176                         $log->logdie("hum, expect at least 8 elements, got ", scalar @e, " in $args") if ($#e < 8);
 177
 178                         if ($log->is_debug) {
 179                                 my $report = "found " . scalar @e . " elements:\n";
 180
 181                                 foreach my $i ( 0 .. $#e ) {
 182                                         $report .= sprintf("# %-2d: %-30s %s\n", $i, ( $e[$i] || 'undef' ), $e[$i]->class );
 183                                 }
 184
 185                                 $log->debug($report);
 186                         }
 187
 188                         my $key_element = $e[8]->clone;
 189
 190                         $log->logdie("key element must be PPI::Structure::Block") unless $key_element->isa('PPI::Structure::Block');
 191
 192                         $log->debug("key part: ", $key_element);
 193
 194                         my @key;
 195
 196                         $key_element->find( sub {
 197                                 my $e = $_[1] || die "no element?";
 198                                 $e->isa('PPI::Token::Word') or return '';
 199                                 $e->content eq 'rec' or return '';
 200
 201                                 my $kf = $e->snext_sibling;
 202
 203                                 $log->debug("key fragment = $kf");
 204
 205                                 push @key, eval $kf;
 206                                 $log->logdie("can't eval { $kf }: $@") if ($@);
 207
 208                                 return 1;
 209                         });
 210
 211                         my $key = join('-', @key ) || $log->logdie("no key found!");
 212
 213                         $log->debug("key = $key");
 214
 215                         my $create = '
 216                                 $coderef = ' . $e[7] . $e[8] . ';
 217                                 foreach my $v ($coderef->()) {
 218                                         next unless (defined($v) && $v ne \'\');
 219                                         push @{ $lookup->{\'' . $key . '\'}->{$v} }, $mfn;
 220                                 }
 221                         ';
 222
 223                         $log->debug("create: $create");
 224
 225                         return $self->_lookup_error("invalid database $e[3] in $path" ) unless $self->valid_database( $e[3] );
 226                         return $self->_lookup_error("invalid input $e[5] of database $e[3] in $path", ) unless $self->valid_database_input( $e[3], $e[5] );
 227
 228                         # save code to create this lookup
 229                         $self->{_lookup_create}->{ _q($e[3]) }->{ _q($e[5]) }->{ _q($key) } .= $create;
 230
 231
 232                         if (defined( $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{ $key } )) {
 233                                 $log->warn("dependency of $database/$input on $e[3]/$e[5] with $key allready recorded");
 234                         }
 235
 236                         # save this dependency
 237                         $self->{depends}->{ $database }->{ $input }->{ _q($e[3]) }->{ _q($e[5]) }->{$key}++;
 238
 239                         if ($#e < 10) {
 240                                 $e[8]->insert_after( $e[8]->clone );
 241                                 $e[8]->insert_after( $e[7]->clone );
 242                                 $e[8]->insert_after( $e[6]->clone );
 243                         }
 244
 245                         $e[7]->remove;
 246                         $e[8]->insert_before( new PPI::Token::Quote::Single( "'$key'" ) );
 247                         $e[8]->remove;
 248
 249
 250                         $log->debug(">>> ", $Element->snext_sibling);
 251         });
 252
 253         my $normalize_source = $Document->serialize;
 254         $log->debug("create: ", dump($self->{_lookup_create}) );
 255         $log->debug("normalize: $normalize_source");
 256
 257         $self->{_normalize_source}->{$database}->{$input} = $normalize_source;
 258
 259         if ($self->{debug}) {
 260                 my $Dumper = PPI::Dumper->new( $Document );
 261                 $Dumper->print;
 262         }
 263
 264         $log->error("Parser errors:\n", join("\n",@{ $self->{_lookup_errors} }) ) if ($self->{_lookup_errors});
 265
 266         return 1;
 267 }
 268
 269
 270 =head2 lookup_create_rules
 271
 272   my $source = $parser->lookup_create_rules($database, $input);
 273
 274 =cut
 275
 276 sub lookup_create_rules {
 277         my $self = shift;
 278         my ($database,$input) = @_;
 279         return $self->{_lookup_create}->{ _q($database) }->{ _q($input) };
 280 }
 281
 282 =head2 valid_database
 283
 284   my $ok = $parse->valid_database('key');
 285
 286 =cut
 287
 288 sub valid_database {
 289         my $self = shift;
 290
 291         my $database = shift || return;
 292
 293         return defined($self->{valid_inputs}->{ _q($database) });
 294 }
 295
 296 =head2 valid_database_input
 297
 298   my $ok = $parse->valid_database('database_key','input_name');
 299
 300 =cut
 301
 302 sub valid_database_input {
 303         my $self = shift;
 304
 305         my ($database,$input) = @_;
 306         return defined($self->{valid_inputs}->{ _q($database) }->{ _q($input) });
 307 }
 308
 309 =head2 depends
 310
 311 Return all databases and inputs on which specified one depends
 312
 313   $depends_on = $parser->depends('database','input');
 314
 315 =cut
 316
 317 sub depends {
 318         my $self = shift;
 319         my ($database,$input) = @_;
 320         $self->_get_logger->debug("depends($database,$input)");
 321         return unless (
 322                 defined( $self->{depends}->{ _q($database) } ) &&
 323                 defined( $self->{depends}->{ _q($database) }->{ _q($input) } )
 324         );
 325         return $self->{depends}->{ _q($database) }->{ _q($input) };
 326 }
 327
 328 =head1 PRIVATE
 329
 330 =head2 _q
 331
 332 Strip single or double quotes around value
 333
 334   _q(qq/'foo'/) -> foo
 335
 336 =cut
 337
 338 sub _q {
 339         my $v = shift || return;
 340         $v =~ s/^['"]*//g;
 341         $v =~ s/['"]*$//g;
 342         return $v;
 343 }
 344
 345 =head2 _input_name
 346
 347 Return C<name> value if HASH or arg if scalar
 348
 349   _input_name($input)
 350
 351 =cut
 352
 353 sub _input_name {
 354         my $input = shift || return;
 355         if (ref($input) eq 'HASH') {
 356                 die "can't find 'name' value in ", dump($input) unless defined($input->{name});
 357                 return $input->{name};
 358         } else {
 359                 return $input;
 360         }
 361 }
 362
 363
 364 =head1 AUTHOR
 365
 366 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 367
 368 =head1 COPYRIGHT & LICENSE
 369
 370 Copyright 2006 Dobrica Pavlinusic, All Rights Reserved.
 371
 372 This program is free software; you can redistribute it and/or modify it
 373 under the same terms as Perl itself.
 374
 375 =cut
 376
 377 1; # End of WebPAC::Parser