## name basic passes
## failures 0
## cut

sub forward;

sub foo {
   my ($self, $bar) = @_;
   print $bar;
   return;
}

sub fu {
   my $self = shift;
   my $bar = shift;
   print $bar;
   return;
}

#-----------------------------------------------------------------------------

## name prototype passes
## failures 0
## cut

sub foo() {
   print $bar;
   return;
}

#-----------------------------------------------------------------------------

## name scheduled subs
## failures 0
## cut

BEGIN {
  print 1;
  print 2;
  print 3;
}

INIT {
  print 1;
  print 2;
  print 3;
}

CHECK {
  print 1;
  print 2;
  print 3;
}

END {
  print 1;
  print 2;
  print 3;
}

#-----------------------------------------------------------------------------

## name passes - no arguments
## failures 0
## cut

sub few { }
sub phu { 1; }
sub phoo { return; }

#-----------------------------------------------------------------------------

## name failure - not idiomatic enough
## failures 2
## cut

sub quux {
    my $self = shift @_;
    print $self;
}

sub cwux {
    my ($self) = ($_[0]);
    print $self;
}

#-----------------------------------------------------------------------------

## name basic failures
## failures 2
## cut

sub bar {
  print $_[0];
  print $_[1];
  print $_[2];
  print $_[3];
}

sub barr {
  print $_[1];
}

#-----------------------------------------------------------------------------

## name failure in an anonymous sub
## failures 1
## TODO PPI v1.118 doesn't recognize anonymous subroutines
## cut

my $x = sub {
  print $_[0];
  print $_[1];
  print $_[2];
  print $_[3];
}

#-----------------------------------------------------------------------------

## name basic failures, set config higher
## failures 1
## parms {short_subroutine_statements => 1}
## cut

sub bar {
  print $_[0];
  print $_[1];
  print $_[2];
  print $_[3];
}

sub barr {
  print $_[1];
}

#-----------------------------------------------------------------------------

## name mixed failures
## failures 2
## cut

sub baz {
  my $self = shift;
  print $_[0];
  print $_[1];
  print $_[2];
  print $_[3];
}

sub baaz {
  my ($self) = @_;
  print $_[0];
  print $_[1];
  print $_[2];
  print $_[3];
}

#-----------------------------------------------------------------------------

## name nested anon sub
## failures 0
## cut

sub baz {
    print "here\n";
    return sub {
        my ($self) = @_;
        print $self->{bar};
    };
}

#-----------------------------------------------------------------------------

## name nested name sub
## failures 0
## cut

sub baz {
    print "here\n";
    sub bar {
        my ($self) = @_;
        print $self->{bar};
    }
    $x->bar();
}

#-----------------------------------------------------------------------------

## name array slice (POE convention), default behavior
## failures 1
## cut

sub foo {
    my ( $kernel, $heap, $input ) = @_[ KERNEL, HEAP, ARG0 ];
}

#-----------------------------------------------------------------------------

## name array slice (POE convention) with indices allowed
## parms { allow_subscripts => '1' }
## failures 0
## cut

sub foo {
    my ( $kernel, $heap, $input ) = @_[ KERNEL, HEAP, ARG0 ];
}

sub bar {
    my $kernel = $_[ KERNEL ];
    my $heap   = $_[ HEAP   ];
    my $input  = $_[ ARG0   ];
}


#-----------------------------------------------------------------------------

## name exclude foreach rt#39601
## failures 0
## cut

sub my_sub {

    my @a = ( [ 1, 2 ], [ 3, 4 ] );
    print @$_[0] foreach @a;

    my @b = ( [ 1, 2 ], [ 3, 4 ] );
    print @$_[0] for @b;

}

#-----------------------------------------------------------------------------

## name and still catch unrolling args in a postfix for
## failures 1
## cut

sub my_sub {

    my @a = ( [ 1, 2 ], [ 3, 4 ] );
    print $_[0] for @a;
}

#-----------------------------------------------------------------------------

## name Allow the usual delegation idioms.
## failures 0
## cut

sub foo {
    my $self = shift;
    return $self->SUPER::foo(@_);
}

sub bar {
    my $self = shift;
    return $self->NEXT::bar(@_);
}

#-----------------------------------------------------------------------------

## name Don't allow delegation to unknown places.
## failures 2
## cut

sub foo {
    my $self = shift;
    # No, Class::C3 doesn't really work this way.
    return $self->Class::C3::foo(@_);
}

sub bar {
    my $self = shift;
    return $self->_unpacker(@_);
}

#-----------------------------------------------------------------------------

## name Allow delegation to places we have been told about.
## failures 0
## parms { allow_delegation_to => 'Class::C3:: _unpacker' }
## cut

sub foo {
    my $self = shift;
    # No, Class::C3 doesn't really work this way.
    return $self->Class::C3::foo(@_);
}

sub bar {
    my $self = shift;
    return $self->_unpacker(@_);
}

#-----------------------------------------------------------------------------

## name Recognize $$_[0] as a use of $_, not @_ (rt #37713)
## failures 0
## cut

sub foo {
    my %hash = ( a => 1, b => 2 );
    my @data = ( [ 10, 'a' ], [ 20, 'b' ], [ 30, 'c' ] );
    # $$_[1] is a funky way to say $_->[1].
    return [ grep { $hash{ $$_[1] } } @data ];
}

#-----------------------------------------------------------------------------

## name Allow tests (rt #79138)
## failures 0
## cut

sub foo {
    my ( $self, $arg ) = @_;

    if ( @_ ) {
        say 'Some arguments';
    }
    unless ( ! @_ ) {
        say 'Some arguments';
    }
    unless ( not @_ ) {
        say 'Some arguments';
    }
    say 'Some arguments'
        if @_;
    say 'Some arguments'
        if ( @_ );
    say 'Some arguments'
        unless ! @_;
    say 'Some arguments'
        unless ( ! @_ );
    say 'Some arguments'
        unless not @_;
    say 'Some arguments'
        unless ( not @_ );
    @_
        and say 'Some arguments';
    ! @_
        or say 'Some arguments';
    not @_
        or say 'Some arguments';

    unless ( @_ ) {
        say 'No arguments';
    }
    if ( ! @_ ) {
        say 'No arguments';
    }
    if ( not @_ ) {
        say 'No arguments';
    }
    say 'No arguments'
        unless @_;
    say 'No arguments'
        unless ( @_ );
    say 'No arguments'
        if ! @_;
    say 'No arguments'
        if ( ! @_ );
    say 'No arguments'
        if not @_;
    say 'No arguments'
        if ( not @_ );
    @_
        or say 'No arguments';
    ! @_
        and say 'No arguments';
    not @_
        and say 'No arguments';

    if ( @_ == 2 ) {
        say 'Two arguments';
    }
    if ( 2 == @_ ) {
        say 'Two arguments';
    }
    @_ == 2
        and say 'Two arguments';
    2 == @_
        and say 'Two arguments';
    say 'Two arguments'
        if @_ == 2;
    say 'Two arguments'
        if ( @_ == 2 );
    unless ( @_ != 2 ) {
        say 'Two arguments';
    }
    unless ( 2 != @_ ) {
        say 'Two arguments';
    }
    say 'Two arguments'
        unless @_ != 2;
    say 'Two arguments'
        unless ( @_ != 2 );

    if ( @_ != 2 ) {
        say 'Not two arguments';
    }
    if ( 2 != @_ ) {
        say 'Not two arguments';
    }
    @_ != 2
        and say 'Not two arguments';
    2 != @_
        and say 'Not two arguments';
    say 'Not two arguments'
        if @_ != 2;
    say 'Not two arguments'
        if ( @_ != 2 );
    unless ( @_ == 2 ) {
        say 'Not two arguments';
    }
    unless ( 2 == @_ ) {
        say 'Not two arguments';
    }
    say 'Not two arguments'
        unless @_ == 2;
    say 'Not two arguments'
        unless ( @_ == 2 );

}

#-----------------------------------------------------------------------------

## name MOOSE idiom (https://github.com/adamkennedy/PPI/issues/74)
## failures 0
## cut

sub BUILD {
    my ($class, $options_ref) = @_;
    $options_ref ||= @_;
}

#-----------------------------------------------------------------------------

## name Anonymous subroutine with attributes and/or prototypes
## failures 0
## cut

sub foo {
    my ( $foo ) = @_;

    my $bar;

    # attribute
    my $baz = sub : lvalue {
        my ( $b ) = @_;
        return $b;
    };

    # prototype
    my $burfle = sub (@) {};

    # both
    my $buzz = sub ($) : lvalue {
        my ( $b ) = @_;
        return $b;
    };

    # signature, which PPI 1.220 parses as prototype
    my $boo = sub ($left, $right) {
        return $left * $right;
    }
}

#-----------------------------------------------------------------------------

## name Params::Validate idiom
## failures 0
## parms { allow_closures => 1 }
## cut

sub foo {
    my @args = $validate->( @_ );
}

sub bar {
    my @args = $validate{bar}->( @_ );
}

#-----------------------------------------------------------------------------

## name Params::Validate idiom must be explicitly enabled
## failures 2
## cut

sub foo {
    my @args = $validate->( @_ );
}

sub bar {
    my @args = $validate{bar}->( @_ );
}

#-----------------------------------------------------------------------------
# Local Variables:
#   mode: cperl
#   cperl-indent-level: 4
#   fill-column: 78
#   indent-tabs-mode: nil
#   c-indentation-style: bsd
# End:
# ex: set ts=8 sts=4 sw=4 tw=78 ft=perl expandtab shiftround :