#!perl
# Marpa::R3 is Copyright (C) 2016, Jeffrey Kegler.
#
# This module is free software; you can redistribute it and/or modify it
# under the same terms as Perl 5.10.1. For more details, see the full text
# of the licenses in the directory LICENSES.
#
# This program is distributed in the hope that it will be
# useful, but it is provided “as is” and without any express
# or implied warranties. For details, see the full text of
# of the licenses in the directory LICENSES.
# CENSUS: ASIS
# Note: SLIF TEST
# This test was originally based on Marpa::R2 Github issue #254 --
# constructor invoked on per-parse argument, which should not happen.
#
# Per-parse constructors and all effects of per-parse arguments were
# eliminated in Marpa::R3, so this test is now very basic and much simpler.
# _The Computer Journal_, Vol. 45, No. 6, pp. 620-630,
# in its "NNF" form
use 5.010001;
use strict;
use warnings;
use English qw( -no_match_vars );
use Test::More tests => 8;
use lib 'inc';
use Marpa::R3::Test;
use Marpa::R3;
use Data::Dumper;
package Class_Actions;
sub do_A {
my ( $self, $values ) = @_;
my ($letter) = @{$values};
return join ';', "class method", "letter=$letter";
}
package Package_Actions;
sub do_A {
my ( $self, $values ) = @_;
my ($letter) = @{$values};
return join ';', "package method", "letter=$letter";
}
package main;
my $grammar =
Marpa::R3::Scanless::G->new( { source => \q(A ::= 'a' action => do_A) } );
my @tests = ();
PPO: for my $ppo_desc ( 'no', 'unblessed', 'same blessed', 'other blessed' ) {
my $recce_arg = {};
my $method_desc = undef;
$recce_arg = { semantics_package => 'Package_Actions' };
$method_desc = 'package method';
my $ppo = undef;
SET_PPO_PARMS: {
last SET_PPO_PARMS if $ppo_desc eq 'no';
if ( $ppo_desc eq 'unblessed' ) {
$ppo = { desc => $ppo_desc };
last SET_PPO_PARMS;
}
if ( $ppo_desc eq 'same blessed' ) {
$ppo = bless { desc => $ppo_desc }, 'Package_Actions';
$method_desc = 'package method' if not defined $method_desc;
last SET_PPO_PARMS;
} ## end if ( $ppo_desc eq 'same blessed' )
if ( $ppo_desc eq 'other blessed' ) {
$ppo = bless { desc => $ppo_desc }, 'Class_Actions';
$method_desc = 'class method' if not defined $method_desc;
last SET_PPO_PARMS;
} ## end if ( $ppo_desc eq 'other blessed' )
die;
} ## end SET_PPO_PARMS:
next PPO if not defined $method_desc;
my $value = join ';', $method_desc, 'letter=a';
my $desc = "$ppo_desc ppo";
push @tests, [ $recce_arg, $ppo, $value, 'Parse OK', $desc ];
} ## end PPO: for my $ppo_desc ( 'no', 'unblessed', 'same blessed',...)
TEST:
for my $test_data (@tests) {
my ( $recce_arg, $ppo, $expected_value, $expected_result,
$test_name )
= @{$test_data};
my ( $actual_value, $actual_result ) =
my_parser( $grammar, $recce_arg, $ppo );
Test::More::is(
Data::Dumper::Dumper( \$actual_value ),
Data::Dumper::Dumper( \$expected_value ),
qq{Value of $test_name}
);
Test::More::is( $actual_result, $expected_result,
qq{Result of $test_name} );
} ## end TEST: for my $test_data (@tests_data)
sub my_parser {
my ( $grammar, $recce_arg, $ppo ) = @_;
my $recce = Marpa::R3::Scanless::R->new( { grammar => $grammar }, $recce_arg );
if ( not defined eval { $recce->read( \'a' ); 1 } ) {
# say $EVAL_ERROR
my $abbreviated_error = $EVAL_ERROR;
chomp $abbreviated_error;
return 'No parse', $abbreviated_error;
} ## end if ( not defined eval { $recce->read( \$string ); 1 ...})
my $value_ref;
if (not defined eval { $value_ref = $recce->value($ppo); 1 } ) {
# say $EVAL_ERROR
my $abbreviated_error = $EVAL_ERROR;
chomp $abbreviated_error;
return 'value() failure', $abbreviated_error;
}
if ( not defined $value_ref ) {
return 'No parse', 'Input read to end but no parse';
}
return ${$value_ref}, 'Parse OK';
} ## end sub my_parser
# vim: expandtab shiftwidth=4: