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
;
}