#!/usr/bin/env perl
use 5.006001;
use Fatal qw< open close >;our $VERSION = '1.101_003';
my $this_program = __FILE__;
(my $test_file_name = $this_program) =~ s/ [.] PL \z //xms;
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";
open my $test_file, '>', $test_file_name
or confess "Could not open $test_file_name: $ERRNO";
print {$test_file} <<"END_HEADER";
# Do not edit!!! This test suite generated by $this_program.
END_HEADER
emit_simple_tests($test_file);
emit_primary_tests($test_file);
emit_footer($test_file);
close $test_file;
print "Done.\n\n";
sub emit_simple_tests {
my ($test_file) = @_;
print {$test_file} <<'END_SIMPLE_TESTS';
#-----------------------------------------------------------------------------
## name Basic Passes
## failures 0
## cut
my $foo;
our $bar;
my($foo, $bar) = ("BLEH", "BLEH");
my @foo;
my %bar;
sub foo {}
my $foo123;
my $foo123bar;
sub foo123 {}
sub foo123bar {}
package This::SomeThing;
package This;
package This::Thing;
package Acme::12345;
package YYZ;
#-----------------------------------------------------------------------------
## name Basic Failures
## failures 14
## cut
my $Foo;
our $Bar;
my @Foo;
my %Bar;
sub Foo {}
my $foo_Bar;
sub foo_Bar {}
my $FooBar;
sub FooBar {}
my $foo123Bar;
sub foo123Bar {}
package pragma;
package Foo::baz;
package baz::FooBar;
#-----------------------------------------------------------------------------
## name Special case: main
## failures 0
## cut
package main;
#-----------------------------------------------------------------------------
## name Combined passes and fails
## failures 2
## cut
my($foo, $Bar);
our($Bar, $foo);
#-----------------------------------------------------------------------------
## name Variables from other packages should pass
## failures 0
## cut
local $Other::Package::Foo;
$Other::Package::Foo;
#-----------------------------------------------------------------------------
## name Only cares about declarations
## failures 0
## cut
Foo();
$Foo = 42;
#-----------------------------------------------------------------------------
## name Constants must be all caps, passes
## failures 0
## cut
Readonly::Scalar my $CONSTANT = 23;
#-----------------------------------------------------------------------------
## name Constants must be all caps, failures
## failures 3
## cut
Readonly::Scalar my $Foo = 23;
Readonly::Scalar my $foo = 23;
Readonly::Scalar my $fooBAR = 23;
#-----------------------------------------------------------------------------
## name PPI misparses part of ternary as a label (RT #41170)
## failures 0
## cut
my $foo = $condition ? $objection->method : $alternative;
my $foo = $condition ? undef : 1;
END_SIMPLE_TESTS
return;
}
sub emit_primary_tests {
my ($test_file) = @_;
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'all_lower_case', 'guaranteed_to_pass', ':single_case', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'ALL_UPPER_CASE', 'guaranteed_to_pass', ':single_case', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'mixedCase', 'guaranteed_to_pass', ':single_case', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'a11_lower_case_with_digits', 'guaranteed_to_pass', ':single_case', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'guaranteed_to_pass', ':single_case', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'all_lower_case', 'guaranteed_to_pass', ':all_lower', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'ALL_UPPER_CASE', 'guaranteed_to_pass', ':all_lower', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'mixedCase', 'guaranteed_to_pass', ':all_lower', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'a11_lower_case_with_digits', 'guaranteed_to_pass', ':all_lower', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'guaranteed_to_pass', ':all_lower', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'all_lower_case', 'GUARANTEED_TO_PASS', ':all_upper', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'ALL_UPPER_CASE', 'GUARANTEED_TO_PASS', ':all_upper', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'mixedCase', 'GUARANTEED_TO_PASS', ':all_upper', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'a11_lower_case_with_digits', 'GUARANTEED_TO_PASS', ':all_upper', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'GUARANTEED_TO_PASS', ':all_upper', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'all_lower_case', 'guaranteed_to_pass', ':starts_with_lower', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'ALL_UPPER_CASE', 'guaranteed_to_pass', ':starts_with_lower', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file,
'________all_lower_case_with_leading_underscores',
'guaranteed_to_pass',
':starts_with_lower',
0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'a11_lower_case_with_digits', 'guaranteed_to_pass', ':starts_with_lower', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'guaranteed_to_pass', ':starts_with_lower', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'all_lower_case', 'GUARANTEED_TO_PASS', ':starts_with_upper', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'ALL_UPPER_CASE', 'GUARANTEED_TO_PASS', ':starts_with_upper', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file,
'________ALL_UPPER_CASE_WITH_LEADING_UNDERSCORES',
'GUARANTEED_TO_PASS',
':starts_with_upper',
0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'a11_lower_case_with_digits', 'GUARANTEED_TO_PASS', ':starts_with_upper', 1,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'GUARANTEED_TO_PASS', ':starts_with_upper', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'all_lower_case', 'guaranteed_to_pass', ':no_restriction', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'ALL_UPPER_CASE', 'guaranteed_to_pass', ':no_restriction', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'mixedCase', 'guaranteed_to_pass', ':no_restriction', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file,
'________ALL_UPPER_CASE_WITH_LEADING_UNDERSCORES',
'guaranteed_to_pass',
':no_restriction',
0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'a11_lower_case_with_digits', 'guaranteed_to_pass', ':no_restriction', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'A11_UPPER_CASE_WITH_DIGITS', 'guaranteed_to_pass', ':no_restriction', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'foobar', 'foo_guaranteed_to_pass_bar', 'foo.*bar', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'fooXYZZYbar', 'foo_guaranteed_to_pass_bar', 'foo.*bar', 0,
);
emit_all_tests_for_name_and_capitalization_scheme(
$test_file, 'xyzzy', 'foo_guaranteed_to_pass_bar', 'foo.*bar', 1,
);
return;
}
sub emit_all_tests_for_name_and_capitalization_scheme {
my ($test_file, $name, $guaranteed_to_pass, $capitalization_scheme, $failures)
= @_;
emit_package_test(
$test_file,
$name,
$guaranteed_to_pass,
$capitalization_scheme,
$failures
);
emit_subroutine_test(
$test_file, $name, $capitalization_scheme, $failures,
);
emit_local_lexical_variable_in_subroutine_test(
$test_file, $name, $capitalization_scheme, $failures,
);
emit_local_lexical_variable_in_scheduled_subroutine_test(
$test_file, $name, $capitalization_scheme, $failures,
);
emit_scoped_lexical_variable_test(
$test_file, $name, $capitalization_scheme, $failures,
);
emit_file_lexical_variable_test(
$test_file, $name, $capitalization_scheme, $failures,
);
emit_global_variable_test(
$test_file, $name, $capitalization_scheme, $failures,
);
emit_foreach_loop_variable_tests(
$test_file, $name, $capitalization_scheme, $failures,
);
emit_c_style_for_loop_variable_tests(
$test_file, $name, $capitalization_scheme, $failures,
);
emit_local_lexical_variable_in_io_assignment_in_while_loop_test(
$test_file, $name, $capitalization_scheme, $failures,
);
emit_label_test($test_file, $name, $capitalization_scheme, $failures);
return;
}
sub emit_package_test {
my ($test_file, $package_name, $good_package_component, $capitalization_scheme, $failures) = @_;
print {$test_file} <<"END_PACKAGE_TEST";
#-----------------------------------------------------------------------------
## name Package named "$package_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { packages => '$capitalization_scheme' }
## cut
package $package_name;
#-----------------------------------------------------------------------------
## name Exempted package named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme.
## failures 0
## parms { packages => '$capitalization_scheme', package_exemptions => 'bLa.*LaH' }
## cut
package bLaHlAhLaH;
#-----------------------------------------------------------------------------
## name Package named "${good_package_component}::$package_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { packages => '$capitalization_scheme' }
## cut
package ${good_package_component}::$package_name;
END_PACKAGE_TEST
return;
}
sub emit_subroutine_test {
my ($test_file, $subroutine_name, $capitalization_scheme, $failures) = @_;
print {$test_file} <<"END_SUBROUTINE_TEST";
#-----------------------------------------------------------------------------
## name Subroutine named "$subroutine_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { subroutines => '$capitalization_scheme' }
## cut
sub $subroutine_name {
# Blah blah blah
}
#-----------------------------------------------------------------------------
## name Exempted subroutine named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme.
## failures 0
## parms { subroutines => '$capitalization_scheme', subroutine_exemptions => 'bLa.*LaH' }
## cut
sub bLaHlAhLaH {
# Blah blah blah
}
END_SUBROUTINE_TEST
return;
}
sub emit_local_lexical_variable_in_subroutine_test {
my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_;
print {$test_file} <<"END_LOCAL_LEXICAL_VARIABLE_TEST";
#-----------------------------------------------------------------------------
## name Local lexical variable in subroutine named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { subroutines => ':all_lower', local_lexical_variables => '$capitalization_scheme' }
## cut
sub some_subroutine {
my \$$variable_name;
}
#-----------------------------------------------------------------------------
## name Exempted local lexical variable in subroutine named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme.
## failures 0
## parms { subroutines => ':all_lower', local_lexical_variables => '$capitalization_scheme', local_lexical_variable_exemptions => 'bLa.*LaH' }
## cut
sub some_subroutine {
my \$bLaHlAhLaH;
}
END_LOCAL_LEXICAL_VARIABLE_TEST
return;
}
sub emit_local_lexical_variable_in_scheduled_subroutine_test {
my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_;
print {$test_file} <<"END_LOCAL_LEXICAL_VARIABLE_TEST";
#-----------------------------------------------------------------------------
## name Local lexical variable in subroutine named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { local_lexical_variables => '$capitalization_scheme' }
## cut
CHECK {
my \$$variable_name;
}
END_LOCAL_LEXICAL_VARIABLE_TEST
return;
}
sub emit_scoped_lexical_variable_test {
my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_;
print {$test_file} <<"END_SCOPED_LEXICAL_VARIABLE_TEST";
#-----------------------------------------------------------------------------
## name Scoped lexical variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { scoped_lexical_variables => '$capitalization_scheme' }
## cut
{
my \$$variable_name;
}
#-----------------------------------------------------------------------------
## name Exempted scoped lexical variable named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme.
## failures 0
## parms { scoped_lexical_variables => '$capitalization_scheme', scoped_lexical_variable_exemptions => 'bLa.*LaH' }
## cut
{
my \$bLaHlAhLaH;
}
END_SCOPED_LEXICAL_VARIABLE_TEST
return;
}
sub emit_file_lexical_variable_test {
my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_;
print {$test_file} <<"END_FILE_LEXICAL_VARIABLE_TEST";
#-----------------------------------------------------------------------------
## name File lexical variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { file_lexical_variables => '$capitalization_scheme' }
## cut
my \$$variable_name;
#-----------------------------------------------------------------------------
## name Exempted file lexical variable named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme.
## failures 0
## parms { file_lexical_variables => '$capitalization_scheme', file_lexical_variable_exemptions => 'bLa.*LaH' }
## cut
my \$bLaHlAhLaH;
END_FILE_LEXICAL_VARIABLE_TEST
return;
}
sub emit_global_variable_test {
my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_;
foreach my $variable_type ( qw< our local > ) {
print {$test_file} <<"END_FILE_LEXICAL_VARIABLE_TEST";
#-----------------------------------------------------------------------------
## name "$variable_type" variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { global_variables => '$capitalization_scheme' }
## cut
$variable_type \$$variable_name;
#-----------------------------------------------------------------------------
## name Exempted "$variable_type" variable named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme.
## failures 0
## parms { global_variables => '$capitalization_scheme', global_variable_exemptions => 'bLa.*LaH' }
## cut
$variable_type \$bLaHlAhLaH;
END_FILE_LEXICAL_VARIABLE_TEST
}
return;
}
sub emit_foreach_loop_variable_tests {
my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_;
print {$test_file} <<"END_FOREACH_LOOP_VARIABLE_TESTS";
#-----------------------------------------------------------------------------
## name Local lexical variable as foreach loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { local_lexical_variables => '$capitalization_scheme' }
## cut
foreach my \$$variable_name (\@_) {
say \$$variable_name;
}
#-----------------------------------------------------------------------------
## name State variable as foreach loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { local_lexical_variables => '$capitalization_scheme' }
## cut
foreach state \$$variable_name (\@_) {
say \$$variable_name;
}
#-----------------------------------------------------------------------------
## name Implied local lexical variable as foreach loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { local_lexical_variables => '$capitalization_scheme' }
## cut
foreach \$$variable_name (\@_) {
say \$$variable_name;
}
#-----------------------------------------------------------------------------
## name Global variable as foreach loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { global_variables => '$capitalization_scheme' }
## cut
foreach our \$$variable_name (\@_) {
say \$$variable_name;
}
#-----------------------------------------------------------------------------
## name Localized builtin variable
## failures 0
## cut
local \$\@;
#-----------------------------------------------------------------------------
## name Localized \$\\
## failures 0
## cut
# \$\\ was missing from the built in global exceptions
local \$\\;
END_FOREACH_LOOP_VARIABLE_TESTS
return;
}
sub emit_c_style_for_loop_variable_tests {
my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_;
print {$test_file} <<"END_C_STYLE_FOR_LOOP_VARIABLE_TESTS";
#-----------------------------------------------------------------------------
## name Local lexical variable as C-style for loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { local_lexical_variables => '$capitalization_scheme' }
## cut
for (my \$$variable_name = -7; \$$variable_name <= 17; \$$variable_name += 3) {
say \$$variable_name;
}
#-----------------------------------------------------------------------------
## name State variable as C-style for loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { local_lexical_variables => '$capitalization_scheme' }
## cut
# Declare the same variable twice in order to catch the case where the
# variable is the second one in the loop definition.
for (state \$$variable_name = -7; \$$variable_name <= 17; \$$variable_name += 3) {
say \$$variable_name;
}
#-----------------------------------------------------------------------------
## name Global variable as C-style for loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { global_variables => '$capitalization_scheme' }
## cut
# Declare the same variable twice in order to catch the case where the
# variable is the second one in the loop definition.
for (our \$$variable_name = -7; \$$variable_name <= 17; \$$variable_name += 3) {
say \$$variable_name;
}
#-----------------------------------------------------------------------------
## name Localized variable as C-style for loop variable named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { global_variables => '$capitalization_scheme' }
## cut
# Localize the same variable twice in order to catch the case where the
# variable is the second one in the loop definition.
for (local \$$variable_name = -7; \$$variable_name <= 17; \$$variable_name += 3) {
say \$$variable_name;
}
#-----------------------------------------------------------------------------
## name Localized builtin variable as C-style for loop variable vs the "$capitalization_scheme" capitalization scheme.
## failures 0
## parms { global_variables => '$capitalization_scheme' }
## cut
for (local \$EVAL_ERROR = -23; \$EVAL_ERROR <= 17; \$EVAL_ERROR += 3) {
say \$EVAL_ERROR;
}
#-----------------------------------------------------------------------------
## name Localized variable in another package as C-style for loop variable vs the "$capitalization_scheme" capitalization scheme.
## failures 0
## parms { global_variables => '$capitalization_scheme' }
## cut
for (local \$Foo::Baz = -23; \$Foo::Baz <= 17; \$Foo::Baz += 3) {
say \$Foo::Baz
}
END_C_STYLE_FOR_LOOP_VARIABLE_TESTS
return;
}
sub emit_local_lexical_variable_in_io_assignment_in_while_loop_test {
my ($test_file, $variable_name, $capitalization_scheme, $failures) = @_;
print {$test_file} <<"END_LOCAL_LEXICAL_VARIABLE_TEST";
#-----------------------------------------------------------------------------
## name Local lexical variable, in I/O assignment in while loop, named "$variable_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { subroutines => ':all_lower', local_lexical_variables => '$capitalization_scheme' }
## cut
sub some_subroutine {
while (my \$$variable_name = <>) {
say \$$variable_name;
}
}
END_LOCAL_LEXICAL_VARIABLE_TEST
return;
}
sub emit_label_test {
my ($test_file, $label_name, $capitalization_scheme, $failures) = @_;
print {$test_file} <<"END_LABEL_TEST";
#-----------------------------------------------------------------------------
## name Label named "$label_name" vs the "$capitalization_scheme" capitalization scheme.
## failures $failures
## parms { labels => '$capitalization_scheme' }
## cut
$label_name:
while ( foo() ) {
next $label_name;
}
#-----------------------------------------------------------------------------
## name Exempted label named "bLaHlAhLaH" vs the "$capitalization_scheme" capitalization scheme.
## failures 0
## parms { labels => '$capitalization_scheme', label_exemptions => 'bLa.*LaH' }
## cut
bLaHlAhLaH:
while ( foo() ) {
next bLaHlAhLaH;
}
END_LABEL_TEST
return;
}
sub emit_footer {
my ($test_file) = @_;
print {$test_file} <<'END_FOOTER';
#-----------------------------------------------------------------------------
## name Variable in continue block gets handled as a local lexical and not a scoped lexical.
## failures 1
## parms { local_lexical_variables => ':all_upper', scoped_lexical_variables => ':all_lower' }
## cut
while (blah) {
blah;
}
continue {
my $this_should_be_local_and_not_scoped;
}
#-----------------------------------------------------------------------------
## name Builtin variables and variables in other packages are exempt.
## failures 0
## parms { global_variables => ':all_lower' }
## cut
local $EVAL_ERROR
local @ARGV;
local %INC;
local $Foo::Bar;
#-----------------------------------------------------------------------------
## name Test customization example in the Capitalization POD passing.
## failures 0
## parms { global_variables => 'G_(?:(?!_)\w)+', global_variable_exemptions => '.*THINGY.*' }
## cut
our $G_FooBar;
our $THINGY;
our @otherTHINGY;
#-----------------------------------------------------------------------------
## name Test customization example in the Capitalization POD failing.
## failures 4
## parms { global_variables => 'G_(?:(?!_)\w)+', global_variable_exemptions => '.*THINGY.*' }
## cut
our $FooBar;
our $G_;
our $G_foo_bar;
our @THING;
#-----------------------------------------------------------------------------
##############################################################################
# $Date: 2009-07-22 10:19:39 -0700 (Wed, 22 Jul 2009) $
# $Author: clonezone $
# $Revision: 3435 $
##############################################################################
# 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 :
END_FOOTER
return;
}