#!perl
# Copyright 2014 Jeffrey Kegler
# This file is part of Marpa::R2. Marpa::R2 is free software: you can
# redistribute it and/or modify it under the terms of the GNU Lesser
# General Public License as published by the Free Software Foundation,
# either version 3 of the License, or (at your option) any later version.
#
# Marpa::R2 is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser
# General Public License along with Marpa::R2. If not, see
# http://www.gnu.org/licenses/.
use 5.010;
use warnings;
use strict;
use English qw( -no_match_vars );
use Getopt::Long ();
use Test::More ( import => [] );
use lib 'pperl';
BEGIN {
my $PPI_problem;
CHECK_PPI: {
if ( not eval { require PPI } ) {
$PPI_problem = "PPI not installed: $EVAL_ERROR";
last CHECK_PPI;
}
if ( not PPI->VERSION(1.206) ) {
$PPI_problem = 'PPI 1.206 not installed';
}
} ## end CHECK_PPI:
if ($PPI_problem) {
Test::More::plan skip_all => $PPI_problem;
}
else {
Test::More::plan tests => 1;
}
} ## end BEGIN
use Marpa::R2;
use Marpa::R2::Perl;
use lib 'inc';
use Marpa::R2::Test;
# Run in utility mode?
my $utility = 0;
die if not Getopt::Long::GetOptions( utility => \$utility );
sub concat {
shift @_;
return join q{}, map { $_ // '!UNDEF in concat!' } @_;
}
my %closure_by_action = (
long_use => sub {
'LONG: ' . join q{ }, map { $_ // q{()} } @_[ 1, 3 .. $#_ ];
},
revlong_use => sub {
'REVLONG: ' . join q{ }, map { $_ // q{()} } @_[ 1, 3 .. $#_ ];
},
perl_version_use => sub {
'PERL: ' . join q{ }, map { $_ // q{()} } @_[ 1, 3 .. $#_ ];
},
short_use => sub {
'SHORT: ' . join q{ }, map { $_ // q{()} } @_[ 1, 3 .. $#_ ];
},
argexpr => \&concat,
);
my %closure_by_lhs = (
prog => sub { return $_[1] . "\n" },
ary => \&concat,
lineseq => sub {
shift @_;
join "\n", grep { defined and length } @_;
},
);
sub gen_closure {
my ( $lhs, $rhs, $action ) = @_;
my $closure = $closure_by_action{$action} // $closure_by_lhs{$lhs};
return $closure if defined $closure and ref $closure eq 'CODE';
die "lhs=$lhs: $closure is not a closure" if defined $closure;
return sub {undef}
if scalar @{$rhs} == 0;
return sub { $_[1] }
if scalar @{$rhs} == 1;
return sub {
my @args = map { $_ // 'undef' } @_[ 1 .. $#_ ];
return
( join "\n", @args )
. "\n$lhs ::= "
. ( join q{ }, map { $_ // q{-} } @{$rhs} ) . q{; };
};
} ## end sub gen_closure
my $parser = Marpa::R2::Perl->new( { closures => \&gen_closure } );
my $default_input = <<'END_OF_TEST_DATA';
use v5;
use 5;
use 5.1;
use xyz;
use v5 xyz;
use 5 xyz;
use 5.1 xyz;
use xyz v5;
use xyz 5;
use xyz 5.1;
use v5 xyz 5;
use 5 xyz 5;
use 5.1 xyz 5;
use xyz v5 5;
use xyz 5 5;
use xyz 5.1 5;
use v5 xyz 5, 5;
use 5 xyz 5, 5;
use 5.1 xyz 5, 5;
use xyz v5 5, 5;
use xyz 5 5, 5;
use xyz 5.1 5, 5;
use xyz 5.1 @a;
END_OF_TEST_DATA
my $string;
if ($utility) {
$string = do { local $RS = undef; <STDIN> };
}
else {
$string = $default_input;
}
my $expected = <<'EOS';
PERL: use v5 ;
PERL: use 5 ;
PERL: use 5.1 ;
SHORT: use xyz () ;
REVLONG: use v5 xyz () ;
REVLONG: use 5 xyz () ;
REVLONG: use 5.1 xyz () ;
LONG: use xyz v5 () ;
LONG: use xyz 5 () ;
LONG: use xyz 5.1 () ;
REVLONG: use v5 xyz 5 ;
REVLONG: use 5 xyz 5 ;
REVLONG: use 5.1 xyz 5 ;
LONG: use xyz v5 5 ;
LONG: use xyz 5 5 ;
LONG: use xyz 5.1 5 ;
REVLONG: use v5 xyz 5,5 ;
REVLONG: use 5 xyz 5,5 ;
REVLONG: use 5.1 xyz 5,5 ;
LONG: use xyz v5 5,5 ;
LONG: use xyz 5 5,5 ;
LONG: use xyz 5.1 5,5 ;
LONG: use xyz 5.1 @a ;
EOS
$parser->read( \$string );
my $result_ref = $parser->eval();
my $result = defined $result_ref ? ${$result_ref} : 'no parse';
if ($utility) {
say $result or die 'say builtin failed';
}
else {
Marpa::R2::Test::is( $result, $expected, 'Test of use statements' );
}
# vim: expandtab shiftwidth=4: