Skip to content

Commit

Permalink
Perlito5 - parser - add special case for scalar()
Browse files Browse the repository at this point in the history
  • Loading branch information
@fglock
fglock committed Oct 13, 2017
1 parent 6996493 commit aa0d729
Show file tree
Hide file tree
Showing 2 changed files with 100 additions and 89 deletions.
45 changes: 28 additions & 17 deletions src5/lib/Perlito5/Grammar/CORE.pm
View file
Expand Up @@ -232,18 +232,23 @@ token term_next_last_redo {
};

token unary_op {
'shift' | 'pop'
'shift' | 'pop' | 'scalar'
};
token term_unary {
<unary_op> <.Perlito5::Grammar::Space::opt_ws>
[
'(' <paren_parse> ')'
{
my $args = Perlito5::Match::flat($MATCH->{paren_parse});
my $op = Perlito5::Match::flat($MATCH->{unary_op});

Perlito5::Compiler::error "Not enough arguments for $op"
if $op eq 'scalar' && $args eq '*undef*';

$MATCH->{capture} = [ 'term',
Perlito5::AST::Apply->new(
code => Perlito5::Match::flat($MATCH->{unary_op}),
arguments => $args eq '*undef*' ? [] : [$args],
code => $op,
arguments => expand_list($args),
namespace => '',
bareword => 0,
)
Expand All @@ -253,9 +258,14 @@ token term_unary {
<argument_parse>
{
my $args = Perlito5::Match::flat($MATCH->{argument_parse});
my $op = Perlito5::Match::flat($MATCH->{unary_op});

Perlito5::Compiler::error "Not enough arguments for $op"
if $op eq 'scalar' && $args eq '*undef*';

$MATCH->{capture} = [ 'term',
Perlito5::AST::Apply->new(
code => Perlito5::Match::flat($MATCH->{unary_op}),
code => $op,
arguments => $args eq '*undef*' ? [] : [$args],
namespace => '',
bareword => $args eq '*undef*' ? 1 : 0,
Expand Down Expand Up @@ -318,20 +328,21 @@ sub term_core {
return;
};

Perlito5::Grammar::Precedence::add_term( 'my' => \&term_declarator );
Perlito5::Grammar::Precedence::add_term( 'our' => \&term_declarator );
Perlito5::Grammar::Precedence::add_term( 'eval' => \&term_eval );
Perlito5::Grammar::Precedence::add_term( 'state' => \&term_declarator );
Perlito5::Grammar::Precedence::add_term( 'local' => \&term_local );
Perlito5::Grammar::Precedence::add_term( 'my' => \&term_declarator );
Perlito5::Grammar::Precedence::add_term( 'our' => \&term_declarator );
Perlito5::Grammar::Precedence::add_term( 'eval' => \&term_eval );
Perlito5::Grammar::Precedence::add_term( 'state' => \&term_declarator );
Perlito5::Grammar::Precedence::add_term( 'local' => \&term_local );
Perlito5::Grammar::Precedence::add_term( 'return' => \&term_return );
Perlito5::Grammar::Precedence::add_term( 'pos' => \&term_pos );
Perlito5::Grammar::Precedence::add_term( 'chomp' => \&term_operator_with_paren );
Perlito5::Grammar::Precedence::add_term( 'chop' => \&term_operator_with_paren );
Perlito5::Grammar::Precedence::add_term( 'next' => \&term_next_last_redo );
Perlito5::Grammar::Precedence::add_term( 'last' => \&term_next_last_redo );
Perlito5::Grammar::Precedence::add_term( 'redo' => \&term_next_last_redo );
Perlito5::Grammar::Precedence::add_term( 'shift' => \&term_unary );
Perlito5::Grammar::Precedence::add_term( 'pop' => \&term_unary );
Perlito5::Grammar::Precedence::add_term( 'pos' => \&term_pos );
Perlito5::Grammar::Precedence::add_term( 'chomp' => \&term_operator_with_paren );
Perlito5::Grammar::Precedence::add_term( 'chop' => \&term_operator_with_paren );
Perlito5::Grammar::Precedence::add_term( 'next' => \&term_next_last_redo );
Perlito5::Grammar::Precedence::add_term( 'last' => \&term_next_last_redo );
Perlito5::Grammar::Precedence::add_term( 'redo' => \&term_next_last_redo );
Perlito5::Grammar::Precedence::add_term( 'shift' => \&term_unary );
Perlito5::Grammar::Precedence::add_term( 'pop' => \&term_unary );
Perlito5::Grammar::Precedence::add_term( 'scalar' => \&term_unary );

Perlito5::Grammar::Precedence::add_term( $_ => \&term_file_test )
for qw( -r -w -x -o -R -W -X -O -e -z -s -f -d -l -p -S -b -c -t -u -g -k -T -B -M -A -C );
Expand Down
144 changes: 72 additions & 72 deletions t/test.pl
View file
Expand Up @@ -1127,78 +1127,78 @@ ($$;$)

_ok( !$diag, _where(), $name );
}
####
#### # Purposefully avoiding a closure.
#### sub __capture {
#### push @::__capture, join "", @_;
#### }
####
#### sub capture_warnings {
#### my $code = shift;
####
#### local @::__capture;
#### local $SIG {__WARN__} = \&__capture;
#### &$code;
#### return @::__capture;
#### }
####
#### # This will generate a variable number of tests.
#### # Use done_testing() instead of a fixed plan.
#### sub warnings_like {
#### my ($code, $expect, $name) = @_;
#### local $Level = $Level + 1;
####
#### my @w = capture_warnings($code);
####
#### cmp_ok(scalar @w, '==', scalar @$expect, $name);
#### foreach my $e (@$expect) {
#### if (ref $e) {
#### like(shift @w, $e, $name);
#### } else {
#### is(shift @w, $e, $name);
#### }
#### }
#### if (@w) {
#### diag("Saw these additional warnings:");
#### diag($_) foreach @w;
#### }
#### }
####
#### sub _fail_excess_warnings {
#### my($expect, $got, $name) = @_;
#### local $Level = $Level + 1;
#### # This will fail, and produce diagnostics
#### is($expect, scalar @$got, $name);
#### diag("Saw these warnings:");
#### diag($_) foreach @$got;
#### }
####
#### sub warning_is {
#### my ($code, $expect, $name) = @_;
#### die sprintf "Expect must be a string or undef, not a %s reference", ref $expect
#### if ref $expect;
#### local $Level = $Level + 1;
#### my @w = capture_warnings($code);
#### if (@w > 1) {
#### _fail_excess_warnings(0 + defined $expect, \@w, $name);
#### } else {
#### is($w[0], $expect, $name);
#### }
#### }
####
#### sub warning_like {
#### my ($code, $expect, $name) = @_;
#### die sprintf "Expect must be a regexp object"
#### unless ref $expect eq 'Regexp';
#### local $Level = $Level + 1;
#### my @w = capture_warnings($code);
#### if (@w > 1) {
#### _fail_excess_warnings(0 + defined $expect, \@w, $name);
#### } else {
#### like($w[0], $expect, $name);
#### }
#### }
####

# Purposefully avoiding a closure.
sub __capture {
push @::__capture, join "", @_;
}

sub capture_warnings {
my $code = shift;

local @::__capture;
local $SIG {__WARN__} = \&__capture;
&$code;
return @::__capture;
}

# This will generate a variable number of tests.
# Use done_testing() instead of a fixed plan.
sub warnings_like {
my ($code, $expect, $name) = @_;
local $Level = $Level + 1;

my @w = capture_warnings($code);

cmp_ok(scalar @w, '==', scalar @$expect, $name);
foreach my $e (@$expect) {
if (ref $e) {
like(shift @w, $e, $name);
} else {
is(shift @w, $e, $name);
}
}
if (@w) {
diag("Saw these additional warnings:");
diag($_) foreach @w;
}
}

sub _fail_excess_warnings {
my($expect, $got, $name) = @_;
local $Level = $Level + 1;
# This will fail, and produce diagnostics
is($expect, scalar @$got, $name);
diag("Saw these warnings:");
diag($_) foreach @$got;
}

sub warning_is {
my ($code, $expect, $name) = @_;
die sprintf "Expect must be a string or undef, not a %s reference", ref $expect
if ref $expect;
local $Level = $Level + 1;
my @w = capture_warnings($code);
if (@w > 1) {
_fail_excess_warnings(0 + defined $expect, \@w, $name);
} else {
is($w[0], $expect, $name);
}
}

sub warning_like {
my ($code, $expect, $name) = @_;
die sprintf "Expect must be a regexp object"
unless ref $expect eq 'Regexp';
local $Level = $Level + 1;
my @w = capture_warnings($code);
if (@w > 1) {
_fail_excess_warnings(0 + defined $expect, \@w, $name);
} else {
like($w[0], $expect, $name);
}
}

#### # Set a watchdog to timeout the entire test file
#### # NOTE: If the test file uses 'threads', then call the watchdog() function
#### # _AFTER_ the 'threads' module is loaded.
Expand Down

0 comments on commit aa0d729

Please sign in to comment.