File Coverage

blib/lib/Parse/Eyapp/Output.pm

Criterion	Covered	Total	%
statement	163	226	72.1
branch	43	82	52.4
condition	5	12	41.6
subroutine	23	27	85.1
pod	0	7	0.0
total	234	354	66.1

#
# Module Parse::Eyapp::Output
#
# This module is based on Francois Desarmenien Parse::Yapp distribution
#
# Copyright © 2006, 2007, 2008, 2009, 2010, 2011, 2012 Casiano Rodriguez-Leon.
# Copyright © 2017 William N. Braswell, Jr.
# All Rights Reserved.
#
# Parse::Yapp is Copyright © 1998, 1999, 2000, 2001, Francois Desarmenien.
# Parse::Yapp is Copyright © 2017 William N. Braswell, Jr.
# All Rights Reserved.
#

package Parse::Eyapp::Output;
use strict;

our @ISA=qw ( Parse::Eyapp::Lalr );

require 5.004;

use Parse::Eyapp::Base qw(compute_lines);
use Parse::Eyapp::Lalr;
use Parse::Eyapp::Driver;
use Parse::Eyapp::Node; # required to have access to $Parse::Eyapp::Node::FILENAME
use File::Basename;
#use Data::Dumper;
use List::Util qw(first);


use Carp;

# Remove tokens that not appear in the right hand side
# of any production
# Check if not quote tokens aren't defined
sub deleteNotUsedTokens {
  my ($self, $term, $termDef) = @_;

  my $rules = $self->{GRAMMAR}{RULES};
  my @usedSymbols = map { @{$_->[1]} } @$rules;
  my %usedSymbols;
  @usedSymbols{@usedSymbols} = ();

  for (@{$self->{GRAMMAR}{DUMMY}}) {
    delete $usedSymbols{$_};
    delete $termDef->{$_};
  }

  for my $token (keys %$term) {
    delete $term->{$token} unless exists $usedSymbols{$token};
  }

  # Emit a warning if exists a non '' token in %usedSymbols that is not in %termdef
  if ($self->{GRAMMAR}{STRICT} && %$termDef) {
    my @undefined = grep { ! exists $termDef->{$_} } grep { m{^[^']} } keys %$term;
    if (@undefined) {
      @undefined = map { "Warning: may be you forgot to define token '$_'?: %token $_ = /someRegExp/" } @undefined;

      local $" = "\n";
      warn "@undefined\n";
    }
  }
}

# builds a trivial lexer
sub makeLexer {
  my $self = shift;

  my $WHITES = 'm{\G(\s+)}gc and $self->tokenline($1 =~ tr{\n}{})';
  my $w = $self->{GRAMMAR}{WHITES}[0];
  if (defined $w)  {
    # if CODE then literally
    if ($self->{GRAMMAR}{WHITES}[2] eq 'CODE') {
      $WHITES = $w;
    }
    else {
      $w =~ s{^/}{/\\G};
      $WHITES = $w.'gc and $self->tokenline($1 =~ tr{\n}{})';
    }
  }

  my $INCREMENTAL = defined($self->{GRAMMAR}{INCREMENTAL}) ? _incrementalLexerText() : '';

  my %term = %{$self->{GRAMMAR}{TERM}};
  delete $term{"\c@"};
  delete $term{'error'};

  my %termdef = %{$self->{GRAMMAR}{TERMDEF}};

  $self->deleteNotUsedTokens(\%term, \%termdef);


  # remove from %term the tokens that were explictly defined
  my @index = grep { !(exists $termdef{$_}) } keys %term;
  %term = map { ($_, $term{$_}) } @index;

  my @term = map { s/'$//; s/^'//; $_ } keys %term;

  @term = sort { length($b) <=> length($a) } @term;
  @term = map { quotemeta } @term;

  # Keep escape characters as \n \r, etc.
  @term = map { s/\\\\(.)/\\$1/g; $_ } @term;

  my $TERM = '';
  if (@term) {
    $TERM = join '|', @term;
    $TERM = "\\G($TERM)";
  }

  # Translate defined tokens
  # sort by line number
  my @termdef = sort { $termdef{$a}->[1] <=> $termdef{$b}->[1] } keys %termdef;

  my $DEFINEDTOKENS = '';
  for my $t (@termdef) {
    if ($termdef{$t}[2] eq 'REGEXP') {
      my $reg = $termdef{$t}[0];
      $reg =~ s{^/}{/\\G}; # add \G at the begining of the regexp
      $DEFINEDTOKENS .= << "EORT";
      ${reg}gc and return ('$t', \$1);
EORT
    }
    elsif ($termdef{$t}[2] eq 'CONTEXTUAL_REGEXP') {
      my $reg = $termdef{$t}[0];
      $reg =~ s{^/}{/\\G}; # add \G at the begining of the regexp
      $DEFINEDTOKENS .= << "EORT";
      \$self->expects('$t') and ${reg}gc and return ('$t', \$1);
EORT
    }
    elsif ($termdef{$t}[2] eq 'CONTEXTUAL_REGEXP_MATCH') {
      my $reg = $termdef{$t}[0];
      my $parser = $termdef{$t}[3][0];
      $reg =~ s{^/}{/\\G}; # add \G at the begining of the regexp
      $DEFINEDTOKENS .= << "EORT";
      \$pos = pos();
      if (${reg}gc) {
        if (\$self->expects('$t')) {
           my \$oldselfpos = \$self->{POS};
           \$self->{POS} = pos();
           if (\$self->YYPreParse('$parser')) {
             \$self->{POS} = \$oldselfpos;
             return ('$t', \$1);
           }
           else {
             \$self->{POS} = \$oldselfpos;
           }
        }
      }
      pos(\$_) = \$pos;
EORT
    }
    elsif ($termdef{$t}[2] eq 'CONTEXTUAL_REGEXP_NOMATCH') {
      my $reg = $termdef{$t}[0];
      my $parser = $termdef{$t}[3][0];
      $reg =~ s{^/}{/\\G}; # add \G at the begining of the regexp
      # factorize, factorize!!!! ohh!!!!
      $DEFINEDTOKENS .= << "EORT";
      \$pos = pos();
      if (${reg}gc) {
        if (\$self->expects('$t')) {
           my \$oldselfpos = \$self->{POS};
           \$self->{POS} = pos();
           if (!\$self->YYPreParse('$parser')) {
             \$self->{POS} = \$oldselfpos;
             return ('$t', \$1);
           }
           else {
             \$self->{POS} = \$oldselfpos;
           }
        }
      }
      pos(\$_) = \$pos;
EORT
    }
    elsif ($termdef{$t}[2] eq 'LITERAL') { # %token without regexp or code definition
      my $reg = $termdef{$t}[0];
      $reg =~ s{^'?}{};   # $reg =~ s{^'?}{/\\G(};
      $reg =~ s{'?$}{};   # $reg =~ s{'?$}{)/};
      $reg = quotemeta($reg);
      $DEFINEDTOKENS .= << "EORT";
      /\\G(${reg})/gc and return (\$1, \$1);
EORT
    }
    elsif ($termdef{$t}[2] eq 'CODE') { # token definition is code
      $DEFINEDTOKENS .= "$termdef{$t}[0]\n";
    }
  }

  my $frame = _lexerFrame();
  $frame =~ s/<>/$INCREMENTAL/;
  $frame =~ s/<>/$WHITES/;

  if (@term) {
    $frame =~ s/<>/m{$TERM}gc and return (\$1, \$1);/
  }
  else {
    $frame =~ s/<>//
  }

  $frame =~ s/<>/$DEFINEDTOKENS/;

  return $frame;
}

sub _incrementalLexerText {

  return << 'ENDOFINCREMENTAL';
if ($self->YYEndOfInput) {
          print $a if defined($a = $self->YYPrompt);
          my $file = $self->YYInputFile;
          $_ = <$file>;
          return ('', undef) unless $_;
        }
ENDOFINCREMENTAL
}

sub _lexerFrame {
  return << 'EOLEXER';
# Default lexical analyzer
our $LEX = sub {
    my $self = shift;
    my $pos;

    for (${$self->input}) {
      <>

      <>;

      <>

<>

      return ('', undef) if ($_ eq '') || (defined(pos($_)) && (pos($_) >= length($_)));
      /\G\s*(\S+)/;
      my $near = substr($1,0,10);

      return($near, $near);

     # die( "Error inside the lexical analyzer near '". $near
     #     ."'. Line: ".$self->line()
     #     .". File: '".$self->YYFilename()."'. No match found.\n");
    }
  }
;
EOLEXER
}

####################################################################
# Returns    : The string '{\n file contents }\n'  with pre and post comments
# Parameters : a file name
sub _CopyModule {
  my ($module, $function, $file) = @_;

  open(DRV,$file) or  die "BUG: could not open $file";
  my $text = join('',);
  close(DRV);

  my $label = $module;
  $label =~ s/::/_/g;
  return << "EOCODE";
  # Loading $module
  BEGIN {
    unless ($module->can('$function')) {
      eval << 'MODULE_$label'
$text
MODULE_$label
    }; # Unless $module was loaded
  } ########### End of BEGIN { load $file }

EOCODE
}

## This sub gives support to the "%tree alias" directive
## Builds the text for the named accessors to the children
sub make_accessors {
  my $accessors = shift; # hash reference: like left => 0

  my $text = '{';
  for (keys(%$accessors)) {
    $text .= "\n      '$_' => $accessors->{$_},";
  }
  return "$text\n   }";
}

# Compute line numbers for the outputfile. Need for debugging
our $pattern = '################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################';

sub Output {
  my($self)=shift;

  $self->Options(@_);

  my ($GRAMMAR, $TERMS, $FILENAME, $PACKAGES, $LABELS); # Cas
  my($package)=$self->Option('classname');

  my $modulino = $self->Option('modulino'); # prompt or undef

  if (defined($modulino)) {
    $modulino = <<"MODULINO";
unless (caller) {
  exit !__PACKAGE__->main('$modulino');
}
MODULINO
  }
  else {
    $modulino = '';
  }

  my $lexerisdefined = $self->Option('lexerisdefined') || $self->{GRAMMAR}{LEXERISDEFINED};
  my $defaultLexer = $lexerisdefined ? q{} : $self->makeLexer();

  my($head,$states,$rules,$tail,$driver, $bypass, $accessors, $buildingtree, $prefix, $conflict_handlers, $state_conflict);
  my($version)=$Parse::Eyapp::Driver::VERSION;
  my($datapos);
  my $makenodeclasses = '';
  $driver='';

      defined($package)
  or $package='Parse::Eyapp::Default'; # may be the caller package?

  $head= $self->Head();
  $rules=$self->RulesTable();
  $states=$self->DfaTable();
  $tail= $self->Tail();

  my $prompt = $self->Prompt();

  # In case the file ends with documentation and without a
  # =cut
  #
  $tail = $tail."\n\n=for None\n\n=cut\n\n" unless $tail =~ /\n\n=cut\n/;
  #local $Data::Dumper::Purity = 1;

  ($GRAMMAR, $PACKAGES, $LABELS) = $self->Rules();
  $bypass = $self->Bypass;
  $prefix = $self->Prefix;

  $conflict_handlers = $self->conflictHandlers;
  $state_conflict = $self->stateConflict;

  $buildingtree = $self->Buildingtree;
  $accessors = $self->Accessors;
  my $accessors_hash = make_accessors($accessors);
  $TERMS = $self->Terms();

  # Thanks Tom! previous double-quote use produced errors in windows
  $FILENAME = q{'}.$self->Option('inputfile').q{'};

  if ($self->Option('standalone')) {
    # Copy Driver, Node and YATW

    $driver .=_CopyModule('Parse::Eyapp::Driver','YYParse', $Parse::Eyapp::Driver::FILENAME);
    $driver .= _CopyModule('Parse::Eyapp::Node', 'm', $Parse::Eyapp::Node::FILENAME);

    # Remove the line use Parse::Eyapp::YATW
    $driver =~ s/\n\s*use Parse::Eyapp::YATW;\n//g;
    $driver .= _CopyModule('Parse::Eyapp::YATW', 'm', $Parse::Eyapp::YATW::FILENAME);

    $makenodeclasses = '$self->make_node_classes('.$PACKAGES.');';
  }
  else {
    $driver = make_header_for_driver_pm();
    $makenodeclasses = '$self->make_node_classes('.$PACKAGES.');';
  }

  my($text)=$self->Option('template') || Driver_pm();

  $text=~s/<<(\$.+)>>/$1/gee;

  $text;
}

sub make_header_for_driver_pm {
  return q{
BEGIN {
  # This strange way to load the modules is to guarantee compatibility when
  # using several standalone and non-standalone Eyapp parsers

  require Parse::Eyapp::Driver unless Parse::Eyapp::Driver->can('YYParse');
  require Parse::Eyapp::Node unless Parse::Eyapp::Node->can('hnew');
}
  };
}

sub Driver_pm {
  return <<'EOT';
########################################################################################
#
#    This file was generated using Parse::Eyapp version <<$version>>.
#
# Copyright © 2006, 2007, 2008, 2009, 2010, 2011, 2012 Casiano Rodriguez-Leon.
# Copyright © 2017 William N. Braswell, Jr.
# All Rights Reserved.
#
# Parse::Yapp is Copyright © 1998, 1999, 2000, 2001, Francois Desarmenien.
# Parse::Yapp is Copyright © 2017 William N. Braswell, Jr.
# All Rights Reserved.
#
#        Don't edit this file, use source file <<$FILENAME>> instead.
#
#             ANY CHANGE MADE HERE WILL BE LOST !
#
########################################################################################
package <<$package>>;
use strict;

push @<<$package>>::ISA, 'Parse::Eyapp::Driver';

<<$prompt>>

<<$driver>>

sub unexpendedInput { defined($_) ? substr($_, (defined(pos $_) ? pos $_ : 0)) : '' }

<<$head>>

<<$defaultLexer>>

################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################

my $warnmessage =<< "EOFWARN";
Warning!: Did you changed the \@<<$package>>::ISA variable inside the header section of the eyapp program?
EOFWARN

sub new {
  my($class)=shift;
  ref($class) and $class=ref($class);

  warn $warnmessage unless __PACKAGE__->isa('Parse::Eyapp::Driver');
  my($self)=$class->SUPER::new(
    yyversion => '<<$version>>',
    yyGRAMMAR  =>
<<$GRAMMAR>>,
    yyLABELS  =>
<<$LABELS>>,
    yyTERMS  =>
<<$TERMS>>,
    yyFILENAME  => <<$FILENAME>>,
    yystates =>
<<$states>>,
    yyrules  =>
<<$rules>>,
################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################
    yybypass       => <<$bypass>>,
    yybuildingtree => <<$buildingtree>>,
    yyprefix       => '<<$prefix>>',
    yyaccessors    => <<$accessors_hash>>,
    yyconflicthandlers => <<$conflict_handlers>>,
    yystateconflict => <<$state_conflict>>,
    @_,
  );
  bless($self,$class);

  <<$makenodeclasses>>
  $self;
}

<<$tail>>
################ @@@@@@@@@ End of User Code @@@@@@@@@ ###################

<<$modulino>>

1;
EOT
}

####################################################################
# Usage      :
#   my $warnings = Parse::Eyapp->new_grammar(
#                                 input=>$translationscheme,
#                                 classname=>'main',
#                                 firstline => 6,
#                                 outputfile => 'main.pm'
#                  );
#  die "$warnings\nSolve Ambiguities. See file main.output\n"  if $warnings;
#
# Returns    : string reporting about the ambiguities and conflicts or ''
# Throws     : croaks if invalid arguments, if the grammar has errors, if can not open
#              files or if the semantic actions have errors
#
# Parameters :
my %_new_grammar = (
  input => undef,
  classname => undef,
  firstline => undef,
  linenumbers => undef,
  outputfile => undef,
);
my $validkeys = do { local $" = ", "; my @validkeys = keys(%_new_grammar); "@validkeys" };

sub new_grammar {
  my $class = shift;

  croak "Error in new_grammar: Use named arguments" if (@_ %2);
  my %arg = @_;
  if (defined($a = first { !exists($_new_grammar{$_}) } keys(%arg))) {
    croak("Parse::Eyapp::Output::new_grammar Error!: unknown argument $a. Valid arguments are: $validkeys")
  }

  my $grammar = $arg{input} or croak "Error in new_grammar: Specify a input grammar";

  my $name = $arg{classname} or croak 'Error in  new_grammar: Please provide a name for the grammar';

  my ($package, $filename, $line) = caller;

  $line = $arg{firstline} if defined($arg{firstline}) and ($arg{firstline} =~ /\d+/);

  my $linenumbers = $arg{linenumbers};
  $linenumbers = 1 unless defined($linenumbers);

  croak "Bad grammar."
    unless my $p = Parse::Eyapp->new(
          input => $grammar,
          inputfile => $filename,
          firstline => $line,
          linenumbers => $linenumbers,
    );

  my $text = $p->Output(classname => $name) or croak "Can't generate parser.";

  my $outputfile = $arg{outputfile};
  croak "Error in new_grammar: Invalid option for parameter linenumber" unless $linenumbers =~ m{[01]};

  if (defined($outputfile)) {
    my($base,$path,$sfx)=fileparse($outputfile,'\..*$');
    $p->outputtables($path, $base);
    my($outfile)="$path$base.pm";
      open(my $OUT,">$outfile")
    or die "Cannot open $outfile for writing.\n";

    compute_lines(\$text, $outfile, $pattern);
    print $OUT $text; #$p->Output(classname  => $name, linenumbers => $linenumbers);
    close $OUT;
  }

  my $x = eval $text;
  $@ and die "Error while compiling your parser: $@\n";
  return $p;
}

1;

__END__