#!/usr/bin/env perl
# Test we can turn on and off various warnings.
use strict;
use warnings;
no warnings qw(uninitialized);
use File::Temp;
use Test::More qw(no_plan);
use_ok('warnings::everywhere');
# All modules will use a common set of methods, defined at the end of
# this test script; pull them in.
my (%perl_function, $current_function);
line:
while (<DATA>) {
next line if !/\S/;
/^ sub \s+ (\S+) \s+ { /x and do {
$current_function = $1;
};
$perl_function{$current_function} .= $_;
}
my @categories_testable = sort keys %perl_function;
if ($ENV{CATEGORY}) {
@categories_testable = grep { /$ENV{CATEGORY}/ } @categories_testable;
}
# We need a temporary directory to write this stuff to.
# When this goes out of scope it should be deleted.
my $dir = File::Temp->newdir(CLEANUP => 1);
push @INC, $dir->dirname;
# Go through each warning violation in turn, checking that
# we can disable it (a) individually, (b) as part of use warnings,
# and (c) as part of use warnings ('all').
for my $warning (@categories_testable) {
ok(warnings::everywhere::disable_warning_category($warning),
"Disable warnings for $warning")
unless $ENV{FAIL};
for my $pragma_suffix ('', q{ ('all')}, qq{ ('$warning')}) {
_test_package(warning => $warning, pragma_suffix => $pragma_suffix);
}
ok(warnings::everywhere::enable_warning_category($warning),
"Enable warnings again for $warning");
}
# Now do the same by having the module import warnings::everywhere
# in its various guises.
for my $warning (@categories_testable) {
for my $pragma_suffix ('', q{ ('all')}, qq{ ('$warning')}) {
for my $module_name ('warnings::everywhere', 'warnings::anywhere',
'goddamn::warnings::anywhere')
{
for my $category (warnings::everywhere::categories_disabled()) {
warnings::everywhere::enable_warning_category($category);
}
_test_package(
warning => $warning,
pragma_suffix => $pragma_suffix,
import => "no $module_name ('$warning');"
);
}
}
}
sub _test_package {
my (%args) = @_;
# Work out what we're going to call this test package.
# Use underscores rather than :: to avoid faffing about with
# creating subdirectories.
(my $package_suffix_pragma = $args{pragma_suffix}) =~ tr/a-z//cd;
$package_suffix_pragma ||= 'standard';
my $package_suffix_import = $args{import} ? 'import' : 'external';
my $package_name = sprintf('test_%s_%s_%s',
$args{warning}, $package_suffix_pragma, $package_suffix_import);
# Build a class that will hopefully run the offending function
# with warnings suitably enabled.
my $module_contents = <<BUILD_PACKAGE;
package $package_name;
$args{import}
use warnings$args{pragma_suffix};
$perl_function{$args{warning}}
1;
BUILD_PACKAGE
# Write this to a file.
ok(open(my $fh_module, '>', $dir->dirname . "/${package_name}.pm"),
"We can write a new module $package_name to $dir");
ok(
(print {$fh_module} $module_contents),
"We can add our generated module contents"
);
ok($fh_module->close, "We can finish writing $package_name to $dir");
# We can use this module.
my @warning_messages;
local $SIG{__WARN__} = sub {
my ($message) = @_;
push @warning_messages, $message;
};
use_ok($package_name);
# Call the appropriate method.
my $method = $args{warning};
$package_name->$method();
undef $SIG{__WARN__};
# We didn't get any warnings
is_deeply(\@warning_messages, [],
"No warnings produced for $args{warning}, $args{pragma_suffix},"
. " import $args{import}");
}
__DATA__
sub ambiguous {
sub foo { 1 };
my $foo = -foo;
}
sub bareword {
my $foo = Foo::;
}
sub closed {
open(my $fh, '<', $0);
close($fh);
flock($fh, 0);
}
sub closure {
my $foo;
sub sort_of_closure {
my $bar = $foo;
}
}
# WONTFIX: debugging. Looks like scary internal magic here.
sub deprecated {
my @foo;
if (defined @foo) {
1;
}
}
sub digit {
my $hex = hex('a curse upon both houses!');
}
sub exec {
exec("hoo____ray! this should never, never, ever work");
}
sub exiting {
sub other_sub {
last loop;
}
loop:
for (1..5) {
other_sub();
}
}
### FIXME: glob? Looks hard to trigger portably
# WONTFIX: inplace - mostly for one-liners, which this pragma isn't for.
# WONTFIX: internal - can't reproduce without serious XS voodoo.
sub illegalproto {
sub foo (this is not a valid prototype) {
return;
}
}
sub io {
require DirHandle;
my $dir_handle = DirHandle->new('.');
$dir_handle->close;
closedir($dir_handle);
}
### TODO: imprecision; can't find it in perldiag
sub layer {
open(my $fh, '<:unix and nothing else', $0);
}
# WONTFIX: malloc - hell no.
sub misc {
my $wannabe_object = { stuff => 'awesome' };
bless $wannabe_object => '';
}
sub newline {
open(my $fh, "You can't have\nnewlines\nin file names\nThat's wrong\n\n");
}
# WONTFIX: non_unicode - can't easily reproduce at the moment
# WONTFIX: nonchar - nor this one
sub numeric {
my $foo = "he-man" ** "greyskull";
}
### FIXME: can't seem to reproduce a once warning
### FIXME: overflow is tricky to trigger on a 64-bit system
sub pack {
sub ultimate_answer {
return 6 * 9;
}
my $foo = pack('p', ultimate_answer());
}
sub parenthesis {
my $foo, $bar = @_;
}
sub pipe {
open (my $fh, "|magritte|")
}
sub portable {
### TODO: does this still work on 32-bit systems?
my $large_number = eval('0b' . (1 x 40));
}
sub precedence {
my ($foo, $bar) = (0, 0);
if ($foo & $bar == 0) {
}
}
sub printf {
my $foo = sprintf('%zebra', 'stripes');
}
sub prototype {
do_stuff(qw(foo bar baz));
sub do_stuff ($) {
return 'meh';
}
}
sub qw {
my @list = qw(haven't, really, understood, the, point, of, this);
}
sub recursion {
# Global variable so we don't get a "won't stay shared" closure warning.
$times::called = 0;
sub try_try_try_again {
if ($times::called++ < 100) {
return try_try_try_again();
}
return;
}
try_try_try_again();
}
sub redefine {
sub bernie_taupin_lyric { 'If I were a sculptor' }
sub bernie_taupin_lyric { 'But then again no' }
}
sub regexp {
my $regexp = qr/[:alpha:]/;
}
# WONTFIX: reserved; difficult to test under use strict, and it's a good one.
### TODO: find a way to trigger the semicolon warning.
### TODO: deal with severe somehow?
### TODO: can't seem to disable signal?
sub substr {
my $parrot = { squawk => 'Polly wants a cracker' };
substr($parrot, 0, 1) = 'parakeet';
}
# WONTFIX: surrogate; nasty UTF16 stuff I don't want to get involved with.
sub syntax {
my $foo = 'foo';
$foo =~ s/[.][.]/\1\2/;
}
# WONTFIX: taint; too much trouble to enable taints and pass them to system
# calls.
# WONTFIX: threads; tricky to emulate, and why the hell would you ever
# make life more difficult for yourself when programming threads?
sub uninitialized {
my $foo;
my $bar = $foo . q{ damn, that was an undef wasn't it?};
return;
}
sub unopened {
my $fh = 'foo';
binmode($fh);
}
sub unpack {
# Straight out of the man page!
my $foo = unpack("H", "\x{2a1}");
}
### FIXME: untie, if anyone cares?
# WONTFIX: utf8; problematic on older perls.
sub void {
my $foo = sort qw(foo bar baz);
}