xref: /dports/textproc/p5-Perl-Lint/Perl-Lint-0.25/t/Policy/Variables/require_localized_punctuation_vars.PL

use strict;
use warnings;

use English qw(-no_match_vars);
use Carp qw(confess);

use B::Keywords qw();
use List::MoreUtils qw< apply uniq >;

my $this_program = __FILE__;
(my $test_file_name = $this_program) =~ s/[.]PL\Z/.t/ms;
if ($this_program eq $test_file_name) {
    confess
        'Was not able to figure out the name of the file to generate.'
        . "This program: $this_program.";
}

print "\n\nGenerating $test_file_name.\n";

my @globals = (
    @B::Keywords::Arrays,
    @B::Keywords::Hashes,
    @B::Keywords::Scalars,
);
push @globals, uniq apply { s/ \A ([^*]) /*$1/xms } @B::Keywords::Filehandles;
my %exemptions = map {$_ => 1} qw(
    $_
    $ARG
    @_
);

my $carat_re = qr/\A [\$%]\^\w+ /xms;

my $numvars = @globals - keys %exemptions;
my $numcarats = grep {!$exemptions{$_} && m/ $carat_re /xms} @globals;

open my $test_file, '>', $test_file_name
    or confess "Could not open $test_file_name: $ERRNO";

print_header($test_file);
print_pass_local($test_file, \@globals);
print_pass_local_deref($test_file, \@globals);
print_pass_non_local_exception($test_file, \@globals);
print_fail_non_local($test_file, \@globals, $numvars, $numcarats);
print_fail_non_local_deref($test_file, \@globals);
print_footer($test_file);

close $test_file
    or confess "Could not close $test_file_name: $ERRNO";

print "Done.\n\n";

sub print_header {
    my ($test_file) = @_;

    print {$test_file} "# DO NOT EDIT!!! This test suite generated by $this_program\n";
    print {$test_file} <<'END_CODE';

use strict;
use warnings;
use Perl::Lint::Policy::Variables::RequireLocalizedPunctuationVars;
use t::Policy::Util qw/fetch_violations/;
use Test::Base::Less;

my $class_name = 'Variables::RequireLocalizedPunctuationVars';

filters {
    params => [qw/eval/], # TODO wrong!
};

for my $block (blocks) {
    my $violations = fetch_violations($class_name, $block->input, $block->params);
    is scalar @$violations, $block->failures, $block->dscr;
}

done_testing;

__DATA__

===
--- dscr: Named magic variables, special case passes
--- failures: 0
--- params:
--- input
local ($_, $RS) = ();
local $SIG{__DIE__} = sub { print "AAAAAAARRRRRGGGGHHHHH....\n"; };
$_ = 1;
$ARG = 1;
@_ = (1, 2, 3);
END_CODE

    return;
}

sub print_pass_local {
    my ($test_file, $globals) = @_;

    print {$test_file} <<'END_CODE';

===
--- dscr: Named magic variables, pass local
--- failures: 0
--- params:
--- input
END_CODE

    for my $varname (@{$globals}) {
        print {$test_file} "local $varname = ();\n";
    }

    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, pass local()
--- failures: 0
--- params:
--- input
END_CODE

    for my $varname (@{$globals}) {
        print {$test_file} "local ($varname) = ();\n";
    }

    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, pass (local)
--- failures: 0
--- params:
--- input
END_CODE

    for my $varname (@{$globals}) {
        print {$test_file} "(local $varname) = ();\n";
    }

    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, pass = (local) =
--- failures: 0
--- params:
--- input
END_CODE

    for my $varname (@{$globals}) {
        print {$test_file} "\@foo = (local $varname) = ();\n";
    }

    return;
}


sub print_pass_local_deref {
    my ($test_file, $globals) = @_;

    my %subscript = (
        '%' => '{foo}',
        '@' => '[0]',
    );

    my @derefs = grep { $subscript{substr $_, 0, 1} } @{ $globals };

    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, pass local dereferenced
--- failures: 0
--- params:
--- input
END_CODE

    foreach my $varname ( @derefs ) {
        my ($sigil, $barename) = $varname =~ m/ (.)(.*) /smx;
        print {$test_file} 'local $', $barename,
            $subscript{$sigil}, " = 'bar';\n";
    }

}


sub print_pass_non_local_exception {
    my ($test_file, $globals) = @_;

    (my $except = "@$globals") =~ s< ([\\']) ><\\$1>gmsx;
    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, pass non-local but in exception list
--- failures: 0
--- params: {require_localized_punctuation_vars =>  {allow => '$except'}}
--- input
END_CODE

    foreach my $varname (@{$globals}) {
        next if $exemptions{$varname};
        print {$test_file} "$varname = ();\n";
    }
}


sub print_fail_non_local {
    my ($test_file, $globals, $numvars, $numcarats) = @_;

    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, fail non-local, non-carats
--- failures: @{[$numvars - $numcarats]}
--- params:
--- input
END_CODE

    for my $varname (@{$globals}) {
        next if $exemptions{$varname};
        next if $varname =~ m/ $carat_re /xms;
        print {$test_file} "$varname = ();\n";
    }

    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, fail non-local, carats
--- failures: $numcarats
--- params:
--- input
END_CODE

    for my $varname (@{$globals}) {
        next if $exemptions{$varname};
        next if $varname !~ m/ $carat_re /xms;
        print {$test_file} "$varname = ();\n";
    }

    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, fail non-local, carats, no space
--- failures: $numcarats
--- params:
--- input
END_CODE

    for my $varname (@{$globals}) {
        next if $exemptions{$varname};
        next if $varname !~ m/ $carat_re /xms;
        print {$test_file} "$varname= ();\n";
    }

    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, fail = (non-local) =
--- failures: $numvars
--- params:
--- input
END_CODE

    for my $varname (@{$globals}) {
        next if $exemptions{$varname};
        print {$test_file} "\@foo = ($varname) = ();\n";
    }

    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, fail (non-local)
--- failures: $numvars
--- params:
--- input
END_CODE

    for my $varname (@{$globals}) {
        next if $exemptions{$varname};
        print {$test_file} "($varname) = ();\n";
    }

    return;
}


sub print_fail_non_local_deref {
    my ($test_file, $globals) = @_;

    my %subscript = (
        '%' => '{foo}',
        '@' => '[0]',
    );

    my @derefs = grep { $subscript{substr $_, 0, 1} && !$exemptions{$_} }
        @{ $globals };
    my $numvars = scalar @derefs;

    print {$test_file} <<"END_CODE";

===
--- dscr: Named magic variables, fail non-local dereferenced
--- failures: $numvars
--- params:
--- input
END_CODE

    foreach my $varname ( @derefs ) {
        my ($sigil, $barename) = $varname =~ m/ (.)(.*) /smx;
        print {$test_file} '$', $barename,
            $subscript{$sigil}, " = 'bar';\n";
    }

}


sub print_footer {
    my ($test_file) = @_;

    print {$test_file} <<'END_CODE';

===
--- dscr: Allowing a variable with a particular sigil doesn't allow other variables with the same name but different sigils
--- failures: 1
--- params: {require_localized_punctuation_vars => {allow => '$ARGV'}}
--- input
@ARGV = (1, 2, 3);

===
--- dscr: Allow "my" as well, RT #33937
--- failures: 0
--- params:
--- input
for my $entry (
   sort {
       my @a = split m{,}xms, $a;
       my @b = split m{,}xms, $b;
       $a[0] cmp $b[0] || $a[1] <=> $b[1]
   } qw( b,6 c,3 )
   )
{
   print;
}

END_CODE

    return;
}