Test-Warn-0.32/0000755000175000017500000000000013027231037012222 5ustar janekjanekTest-Warn-0.32/t/0000755000175000017500000000000013027231037012465 5ustar janekjanekTest-Warn-0.32/t/warnings_are.t0000755000175000017500000000703413025221272015336 0ustar janekjanek#!/usr/bin/perl BEGIN { chdir 't' if -d 't'; unshift @INC, '../blib/lib'; } use strict; use warnings; use Carp; use constant SUBTESTS_PER_TESTS => 16; use constant TESTS =>( [ "ok", ["my warning"], ["my warning"], "standard warning to find"], ["not ok", ["my warning"], ["another warning"], "another warning instead of my warning"], ["not ok", ["warning general not"], ["warning general"], "quite only a sub warning"], ["not ok", [], ["a warning"], "no warning, but expected one"], ["not ok", ["a warning"], [], "warning, but didn't expect one"], [ "ok", [], [], "no warning"], [ "ok", ['$!"%&/()='], ['$!"%&/()='], "warning with crazy letters"], ["not ok", ["warning 1","warning 2"], ["warning 1"], "more than one warning (1)"], ["not ok", ["warning 1","warning 2"], ["warning 2"], "more than one warning (2)"], [ "ok", ["warning 1","warning 2"], ["warning 1", "warning 2"], "more than one warning (standard ok)"], [ "ok", ["warning 1","warning 1"], ["warning 1", "warning 1"], "more than one warning (two similar warnings)"], ["not ok", ["warning 1","warning 2"], ["warning 2", "warning 1"], "more than one warning (different order)"], [ "ok", [ 1 .. 20 ], [ 1 .. 20 ], "many warnings ok"], ["not ok", [ 1 .. 20 ], [ 1 .. 21 ], "many, but diff. warnings"] ); use Test::Builder::Tester tests => TESTS() * SUBTESTS_PER_TESTS; use Test::Warn; Test::Builder::Tester::color 'on'; use constant WARN_LINE => line_num +2; sub _make_warn { warn $_ for @_; } use constant CARP_LINE => line_num +2; sub _make_carp { carp $_ for @_; } use constant CARP_LEVELS => (0 .. 3); sub _create_exp_warning { my ($carplevel, $warning) = @_; # ['x', 'y', 'z'] return $warning if $carplevel == 0; return [map { {carped => $_} } @$warning] if $carplevel == 1; return {carped => $warning} if $carplevel == 2; return [{carped => $warning}] if $carplevel == 3; } my $i = 0; test_warnings_are(@$_) foreach TESTS(); sub test_warnings_are { my ($ok, $msg, $exp_warning, $testname) = @_; for my $carp (CARP_LEVELS) { *_found_msg = $carp ? *_found_carp_msg : *_found_warn_msg; *_exp_msg = $carp ? *_exp_carp_msg : *_exp_warn_msg; *_make_warn_or_carp = $carp ? *_make_carp : *_make_warn; for my $t (undef, $testname) { for my $is_or_are (qw/is are/) { test_out "$ok 1" . ($t ? " - $t" : ""); if ($ok =~ /not/) { test_fail +5; test_diag _found_msg(@$msg); test_diag _exp_msg(@$exp_warning); } my $ew = _create_exp_warning($carp, $exp_warning); $is_or_are eq 'is' ? warning_is {_make_warn_or_carp(@$msg)} $ew, $t : warnings_are {_make_warn_or_carp(@$msg)} $ew, $t; test_test "$testname (with" . ($_ ? "" : "out") . " a testname)"; } } } } sub _found_warn_msg { @_ ? map({"found warning: $_ at ". __FILE__ . " line " . WARN_LINE . "." } @_) : "didn't find a warning"; } sub _found_carp_msg { @_ ? map({"found carped warning: $_ at ". __FILE__ . " line " . CARP_LINE .($Carp::VERSION gt "1.24"?".":"") } @_) : "didn't find a warning"; } sub _exp_warn_msg { @_ ? map({"expected to find warning: $_" } @_) : "didn't expect to find a warning"; } sub _exp_carp_msg { @_ ? map({"expected to find carped warning: $_" } @_) : "didn't expect to find a warning"; } Test-Warn-0.32/t/warnings_exist1.pl0000644000175000017500000000075313025221272016152 0ustar janekjanek#!/usr/bin/perl use strict; use warnings; use Test::More qw(no_plan); use Test::Warn; warnings_exist { warn "warn_1"; warn "warn_2"; } [qr/warn_1/]; warnings_exist { warn "warn_1"; warn "warn_2"; } [qr/warn_1/,qr/warn_2/]; warnings_exist { warn "warn_2"; } [qr/warn_1/]; warnings_exist { my $a; $b=$a+1; warn "warn_2"; } ['uninitialized']; warnings_exist { warn "warn_2"; } ['uninitialized']; warnings_exist { my $a; $b=$a+1; warn "warn_2"; } [qr/warn_2/]; Test-Warn-0.32/t/warning_is.t0000644000175000017500000000633313025224010015006 0ustar janekjanek#!/usr/bin/perl BEGIN { chdir 't' if -d 't'; unshift @INC, '../blib/lib'; } use strict; use warnings; use Carp; use constant SUBTESTS_PER_TESTS => 6; use constant TESTS =>( ["ok", "my warning", "my warning", "standard warning to find"], ["not ok", "my warning", "another warning", "another warning instead of my warning"], ["not ok", "warning general not", "warning general", "quite only a sub warning"], ["not ok", undef, "a warning", "no warning, but expected one"], ["not ok", "a warning", undef, "warning, but didn't expect one"], ["ok", undef, undef, "no warning"], ["ok", '$!"%&/()=', '$!"%&/()=', "warning with crazy letters"], ["not ok", "warning 1|warning 2", "warning1", "more than one warning"], ["ok","warning\n","warning\n","warning with trailing newline"], ); use Test::Builder::Tester tests => TESTS() * SUBTESTS_PER_TESTS; use Test::Warn; #use Test::Exception; Test::Builder::Tester::color 'on'; use constant WARN_LINE => line_num +2; sub _make_warn { warn $_ for grep $_, split m:\|:, (shift() || ""); } use constant CARP_LINE => line_num +2; sub _make_carp { carp $_ for grep $_, split m:\|:, (shift() || ""); } use constant CARP_LEVELS => (0 .. 2); sub _create_exp_warning { my ($carplevel, $warning) = @_; return $warning if $carplevel == 0; return {carped => $warning} if $carplevel == 1; return {carped => [$warning]} if $carplevel == 2; } test_warning_is(@$_) foreach TESTS(); sub test_warning_is { my ($ok, $msg, $exp_warning, $testname) = @_; for my $carp (CARP_LEVELS) { *_found_msg = $carp ? *_found_carp_msg : *_found_warn_msg; *_exp_msg = $carp ? *_exp_carp_msg : *_exp_warn_msg; *_make_warn_or_carp = $carp ? *_make_carp : *_make_warn; for my $t (undef, $testname) { test_out "$ok 1" . ($t ? " - $t" : ""); if ($ok =~ /not/) { test_fail +4; test_diag _found_msg($_) for ($msg ? (split m-\|-, $msg) : $msg); test_diag _exp_msg($exp_warning); } warning_is {_make_warn_or_carp($msg)} _create_exp_warning($carp, $exp_warning), $t; test_test "$testname (with" . ($_ ? "" : "out") . " a testname)"; } } } sub _found_warn_msg { defined($_[0]) ? ( join " " => ("found warning:", $_[0], "at", __FILE__, "line", WARN_LINE . ".") ) : "didn't find a warning"; } sub _exp_warn_msg { defined($_[0]) ? "expected to find warning: $_[0]" : "didn't expect to find a warning"; } sub _found_carp_msg { defined($_[0]) ? ( join " " => ("found carped warning:", $_[0], "at", __FILE__, "line", CARP_LINE.($Carp::VERSION gt "1.24"?".":"") ) ) # Note the difference, that carp msg : "didn't find a warning"; # aren't finished by '.' } sub _exp_carp_msg { defined($_[0]) ? "expected to find carped warning: $_[0]" : "didn't expect to find a warning"; } Test-Warn-0.32/t/warning_like.t0000644000175000017500000000666513025221272015336 0ustar janekjanek#!/usr/bin/perl BEGIN { chdir 't' if -d 't'; unshift @INC, '../blib/lib'; } use strict; use warnings; use Carp; #expected, warning text, expected, test name use constant TESTS =>( ["ok", "my warning", "my", "standard warning to find"], ["not ok", "my warning", "another", "another warning instead of my warning"], ["not ok", "warning general not", "^(?!warning general)", "quite only a sub warning"], ["not ok", undef, "a warning", "no warning, but expected one"], ["not ok", "a warning", undef, "warning, but didn't expect one"], ["ok", undef, undef, "no warning"], ["ok", '$!"%&/()=', '\$\!\"\%\&\/\(\)\=', "warning with crazy letters"], ["not ok", "warning 1|warning 2", "warning1", "more than one warning"] ); use constant SUBTESTS_PER_TESTS => 12; use Test::Builder::Tester tests => TESTS() * SUBTESTS_PER_TESTS; #use Test::Exception; use Test::Warn; Test::Builder::Tester::color 'on'; use constant WARN_LINE => line_num +2; sub _make_warn { warn $_ for grep $_, split m:\|:, (shift() || ""); } use constant CARP_LINE => line_num +2; sub _make_carp { carp $_ for grep $_, split m:\|:, (shift() || ""); } use constant CARP_LEVELS => (0 .. 2); sub _create_exp_warning { my ($carplevel, $warning) = @_; return $warning if $carplevel == 0; return {carped => $warning} if $carplevel == 1; return {carped => [$warning]} if $carplevel == 2; } test_warning_like(@$_) foreach TESTS(); sub test_warning_like { my ($ok, $msg, $exp_warning, $testname) = @_; for my $carp (CARP_LEVELS) { *_found_msg = $carp ? *_found_carp_msg : *_found_warn_msg; *_exp_msg = $carp ? *_exp_carp_msg : *_exp_warn_msg; *_make_warn_or_carp = $carp ? *_make_carp : *_make_warn; for my $t (undef, $testname) { my @regexes = $exp_warning ? (qr/$exp_warning/, "/$exp_warning/") : (undef, undef); # simpler to count the tests for my $regex (@regexes) { test_out "$ok 1" . ($t ? " - $t" : ""); if ($ok =~ /not/) { test_fail +4; test_diag _found_msg($_) for ($msg ? (split m-\|-, $msg) : $msg); test_diag _exp_msg($regex); } warning_like {_make_warn_or_carp($msg)} _create_exp_warning($carp, $regex), $t; test_test "$testname (with" . ($_ ? "" : "out") . " a testname)"; } } } } sub _found_warn_msg { defined($_[0]) ? ( join " " => ("found warning:", $_[0], "at", __FILE__, "line", WARN_LINE . ".") ) : "didn't find a warning"; } sub _exp_warn_msg { defined($_[0]) ? "expected to find warning: $_[0]" : "didn't expect to find a warning"; } sub _found_carp_msg { defined($_[0]) ? ( join " " => ("found carped warning:", $_[0], "at", __FILE__, "line", CARP_LINE.($Carp::VERSION gt "1.24"?".":"") ) ) # Note the difference, that carp msg : "didn't find a warning"; # aren't finished by '.' } sub _exp_carp_msg { defined($_[0]) ? "expected to find carped warning: $_[0]" : "didn't expect to find a warning"; } Test-Warn-0.32/t/carped.t0000644000175000017500000000451013025221272014106 0ustar janekjanek#!/usr/bin/perl use strict; use warnings; use Carp; use Test::Builder::Tester tests => 6; Test::Builder::Tester::color 'on'; use Test::Warn; sub foo { warn "Warning 1"; carp "Carping 2"; carp "Carping 3"; warn "Warning 4"; } #use File::Spec; #my $tcarped = File::Spec->catfile('t','carped.t'); #$tcarped =~ s/\\/\//g if $^O eq 'MSWin32'; #also will not work on VMS my $tcarped = $0; #'t/carped.t'; test_out "ok 1"; warnings_like {foo()} [map {qr/$_/} (1 .. 4)]; test_test "Warnings and Carpings mixed, asked only for like warnings"; test_out "not ok 1"; my @test_diag = ( "found warning: Warning 1 at $tcarped line 13.", "found carped warning: Carping 2 at $tcarped line 14".($Carp::VERSION gt "1.24"?".":""), "found carped warning: Carping 3 at $tcarped line 15".($Carp::VERSION gt "1.24"?".":""), "found warning: Warning 4 at $tcarped line 16.", "expected to find carped warning: (?-xism:1)", "expected to find carped warning: (?-xism:2)", "expected to find carped warning: (?-xism:3)", "expected to find carped warning: (?-xism:4)", ); if (qr/x/ =~ /\(\?\^/){ s/-xism/^/ for @test_diag } test_fail +2; test_diag @test_diag; warnings_like {foo()} [{carped => [map {qr/$_/} (1 .. 4)]}]; test_test "Warnings and Carpings mixed, asked only for like carpings"; test_out "ok 1"; warnings_like {foo()} [qr/1/, {carped => [qr/2/, qr/3/]}, qr/4/]; test_test "Warnings and Carpings mixed, asked for the right likes"; my @msg = ("Warning 1", "Carping 2", "Carping 3", "Warning 4"); test_out "ok 1"; warnings_are {foo()} \@msg; test_test "Warnings and Carpings mixed, asked only for warnings"; test_out "not ok 1"; test_fail +10; test_diag "found warning: Warning 1 at $tcarped line 13.", "found carped warning: Carping 2 at $tcarped line 14".($Carp::VERSION gt "1.24"?".":""), "found carped warning: Carping 3 at $tcarped line 15".($Carp::VERSION gt "1.24"?".":""), "found warning: Warning 4 at $tcarped line 16.", "expected to find carped warning: Warning 1", "expected to find carped warning: Carping 2", "expected to find carped warning: Carping 3", "expected to find carped warning: Warning 4"; warnings_are {foo()} {carped => \@msg}; test_test "Warnings and Carpings mixed, asked only for carpings"; test_out "ok 1"; warnings_are {foo()} [$msg[0], {carped => [@msg[1..2]]}, $msg[3]]; test_test "Warnings and Carpings mixed, asked for the right ones"; Test-Warn-0.32/t/warnings_exist.t0000644000175000017500000000147113025221272015717 0ustar janekjanek#!/usr/bin/perl use strict; use warnings; use Carp; use Test::More qw(no_plan); my $file="t/warnings_exist1.pl"; my $output=`$^X -Mblib $file 2>&1`; $output=~s/^#.*$//gm; $output=~s/\n{2,}/\n/gs; my @lines=split /[\n\r]+/,$output; shift @lines if $lines[0]=~/^Using /; #extra line in perl 5.6.2 shift @lines if $lines[0]=~/^TAP version /; #extra line in new TAP #print $output; my @expected=( "warn_2 at $file line 12.", 'ok 1', 'ok 2', "warn_2 at $file line 21.", 'not ok 3', "warn_2 at $file line 27.", 'ok 4', "warn_2 at $file line 31.", 'not ok 5', qr/^Use of uninitialized value (?:\$a\s+)?in addition \(\+\) at \Q$file\E line 36\.$/, 'ok 6', '1..6' ); foreach my $i (0..$#expected) { if ($expected[$i]=~/^\(\?\^?\w*-?\w*:/) { like($lines[$i],$expected[$i]); } else { is($lines[$i],$expected[$i]); } } Test-Warn-0.32/t/warnings_like.t0000755000175000017500000000737213025221272015520 0ustar janekjanek#!/usr/bin/perl BEGIN { chdir 't' if -d 't'; unshift @INC, '../blib/lib'; } use strict; use warnings; #use Test::Exception; use Carp; #expected, warning text, expected, test name use constant TESTS =>( [ "ok", ["my warning"], ["my"], "standard warning to find"], ["not ok", ["my warning"], ["another"], "another warning instead of my warning"], ["not ok", ["warning general not"], ["^(?!warning general)"], "quite only a sub warning"], ["not ok", [], ["a warning"], "no warning, but expected one"], ["not ok", ["a warning"], [], "warning, but didn't expect one"], [ "ok", [], [], "no warning"], [ "ok", ['$!"%&/()='], ['\$\!\"\%\&\/\(\)\='], "warning with crazy letters"], ["not ok", ["warning 1","warning 2"], ["warning 1"], "more than one warning (1)"], ["not ok", ["warning 1","warning 2"], ["warning 2"], "more than one warning (2)"], [ "ok", ["warning 1","warning 2"], ["warning 1", "warning 2"], "more than one warning (standard ok)"], [ "ok", ["warning 1","warning 1"], ["warning 1", "warning 1"], "more than one warning (two similar warnings)"], ["not ok", ["warning 1","warning 2"], ["warning 2", "warning 1"], "more than one warning (different order)"], [ "ok", [ 1 .. 20 ], [ 1 .. 20 ], "many warnings ok"], ["not ok", [ 1 .. 20 ], [ 1 .. 21 ], "many, but diff. warnings"] ); use constant SUBTESTS_PER_TESTS => 32; use Test::Builder::Tester tests => TESTS() * SUBTESTS_PER_TESTS; use Test::Warn; Test::Builder::Tester::color 'on'; use constant WARN_LINE => line_num +2; sub _make_warn { warn $_ for @_; } use constant CARP_LINE => line_num +2; sub _make_carp { carp $_ for @_; } use constant CARP_LEVELS => (0 .. 3); sub _create_exp_warning { my ($carplevel, $warning) = @_; # ['x', 'y', 'z'] return $warning if $carplevel == 0; return [map { {carped => $_} } @$warning] if $carplevel == 1; return {carped => $warning} if $carplevel == 2; return [{carped => $warning}] if $carplevel == 3; } my $i = 0; test_warnings_like(@$_) foreach TESTS(); sub test_warnings_like { my ($ok, $msg, $exp_warning, $testname) = @_; for my $regexes ([map {qr/$_/} @$exp_warning], [map {"/$_/"} @$exp_warning]) { for my $carp (CARP_LEVELS) { *_found_msg = $carp ? *_found_carp_msg : *_found_warn_msg; *_exp_msg = $carp ? *_exp_carp_msg : *_exp_warn_msg; *_make_warn_or_carp = $carp ? *_make_carp : *_make_warn; for my $t (undef, $testname) { for my $is_or_are (qw/is are/) { test_out "$ok 1" . ($t ? " - $t" : ""); if ($ok =~ /not/) { test_fail +5; test_diag _found_msg(@$msg); test_diag _exp_msg(@$regexes); } my $ew = _create_exp_warning($carp, $regexes); $is_or_are eq 'is' ? warning_like {_make_warn_or_carp(@$msg)} $ew, $t : warnings_like {_make_warn_or_carp(@$msg)} $ew, $t; test_test "$testname (with" . ($t ? "" : "out") . " a testname)"; } } } } } sub _found_warn_msg { @_ ? map({"found warning: $_ at ". __FILE__ . " line " . WARN_LINE . "." } @_) : "didn't find a warning"; } sub _found_carp_msg { @_ ? map({"found carped warning: $_ at ". __FILE__ . " line " . CARP_LINE .($Carp::VERSION gt "1.24"?".":"") } @_) : "didn't find a warning"; } sub _exp_warn_msg { @_ ? map({"expected to find warning: $_" } @_) : "didn't expect to find a warning"; } sub _exp_carp_msg { @_ ? map({"expected to find carped warning: $_" } @_) : "didn't expect to find a warning"; } Test-Warn-0.32/t/1.t0000644000175000017500000000076213025221272013015 0ustar janekjanek# Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl 1.t' ######################### # change 'tests => 1' to 'tests => last_test_to_print'; use Test; BEGIN { plan tests => 1 }; use Test::Warn; ok(1); # If we made it this far, we're ok. ######################### # Insert your test code below, the Test::More module is use()ed here so read # its man page ( perldoc Test::More ) for help writing this test script. Test-Warn-0.32/Changes0000644000175000017500000000675513027230436013534 0ustar janekjanekRevision history for Perl extension Test::Warn. 0.32 2016-12-23 - updating github information - updating changes 0.31 2016-12-16 - handling warnings with trailing newlines 0.30 2014-03-05 - important note in documentation how check for warning category is done If you use Test::Warn with categories, you should check that it does what you expect. - Category tree is now dynamic and does not use Tree::DAG_Node (Graham Knop) 0.24=0.23_01 2012-04-01 0.23_01 2012-02-25 - compatibility with Carp 1.25 (RURBAN) - require Carp 1.22 - carped.t would better work on Windows 0.23 2011-02-24 - compatibility with Perl 5.14 (ANDK) 0.22 Sep 10 2010 - fixes in English 0.21 Aug 29 2009 - rename internal package Tree::MyDAG_Node with Test::Warn::DAG_Node_Tree 0.20 Aug 29 2009 - fix warning_exists.t for perl 5.6.2 - warnings_exists was renamed to warnings_exist - compatibility layer in Makefile.PL 0.11_02 Jun 16 2009 - carped.t will work on VMS (RT#39579) - fix warning_exists.t for perl 5.10 - warning_exists was renamed to warnings_exists 0.11_01 Jun 14 2009 - small changes - MIN_PERL_VERSION in Makefile.PL - Array::Compare is not needed - allow files with spaces in path (RT#21545 by frew ) - Test::Exception is also not needed - warning_exists added 0.11 Jul 09 2008 - better Makefile.PL - mention Test::Trap - uplevel 2 changed to uplevel 1 to work with Sub::Uplevel 0.19_02 - small fixes 0.10 May 01 2007 - depend on newer version of Sub::Uplevel - fixed pod error 0.09 Mar 15 2007 - new maintainer: Alexandr Ciornii - license in Makefile.PL - fixed carped.t (patch by PSINNOTT) - pod.t 0.08 Tue Sep 02 2003 - fixed bug in warning_is, warnings_are when newlines are inside 0.07 Mon Mar 10 2003 - fixed self test routines that it doesn't play a role what kind of file separator is used (/ on *nix or \ on win) - added File::Spec to the requirements 0.06 Wed Jul 31 2002 - used a patch given by chromatic and Schwern to remove Dependancy of Switch - fixed a typo in the doc 0.05 Thu Jul 25 2002 - implemented the warnings category feature warning_like {foo()} 'syntax', "Test for any syntax warning, given by the standard perl distribution"; - added Tree::DAG_Node to the requirements 0.04 Tue Jul 16 2002 - implemented the possibility of saying warning_like {foo()} {carped => ['x', 'y', 'z']}, "Warnings with x, y and z" instead of warning_like {foo()} [{carped => 'x'}, {carped => 'y'}, {carped => 'z'}], "Warnings with x, y and z, too" - added Dependancy to Switch 0.03 Mon Jul 15 2002 - removed bug that occured with some versions of perl Something something like use List::Util qw/first/; {$warn_kind => first {"$_\n"} split /\n/, $msg}; where the argument to first wasn't detected as a sub block - removed Dependency of List::Util 0.02 Thu Jul 11 2002 - implemented carped option to define a warning coming from carp 0.01 Wed Jul 10 2002 - first CPAN release - warning_is / warning_are implemented - warning_like / warnings_like implemented Test-Warn-0.32/META.yml0000644000175000017500000000144213027231037013474 0ustar janekjanek--- abstract: 'Perl extension to test methods for warnings' author: - 'Alexandr Ciornii ' build_requires: ExtUtils::MakeMaker: '0' File::Spec: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.1, CPAN::Meta::Converter version 2.150005' keywords: - testing - warnings license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test-Warn no_index: directory: - t - inc requires: Carp: '1.22' Sub::Uplevel: '0.12' Test::Builder: '0.13' Test::Builder::Tester: '1.02' perl: '5.006' resources: repository: git://github.com/hanfried/test-warn.git version: '0.32' x_serialization_backend: 'CPAN::Meta::YAML version 0.012' Test-Warn-0.32/Warn.pm0000644000175000017500000003542313027230425013476 0ustar janekjanek=head1 NAME Test::Warn - Perl extension to test methods for warnings =head1 SYNOPSIS use Test::Warn; warning_is {foo(-dri => "/")} "Unknown Parameter 'dri'", "dri != dir gives warning"; warnings_are {bar(1,1)} ["Width very small", "Height very small"]; warning_is {add(2,2)} undef, "No warnings for calc 2+2"; # or warnings_are {add(2,2)} [], "No warnings for calc 2+2"; # what reads better :-) warning_like {foo(-dri => "/")} qr/unknown param/i, "an unknown parameter test"; warnings_like {bar(1,1)} [qr/width.*small/i, qr/height.*small/i]; warning_is {foo()} {carped => "didn't find the right parameters"}; warnings_like {foo()} [qr/undefined/,qr/undefined/,{carped => qr/no result/i}]; warning_like {foo(undef)} 'uninitialized'; warning_like {bar(file => '/etc/passwd')} 'io'; warning_like {eval q/"$x"; $x;/} [qw/void uninitialized/], "some warnings at compile time"; warnings_exist {...} [qr/expected warning/], "Expected warning is thrown"; =head1 DESCRIPTION A good style of Perl programming calls for a lot of diverse regression tests. This module provides a few convenience methods for testing warning based code. If you are not already familiar with the Test::More manpage now would be the time to go take a look. =head2 FUNCTIONS =over 4 =item warning_is BLOCK STRING, TEST_NAME Tests that BLOCK gives the specified warning exactly once. The test fails if the BLOCK warns more than once or does not warn at all. If the string is undef, then the tests succeeds if the BLOCK doesn't give any warning. Another way to say that there are no warnings in the block is C. If you want to test for a warning given by Carp, you have to write something like: C 'msg'}, "Test for a carped warning">. The test will fail if a "normal" warning is found instead of a "carped" one. Note: C would print something like C. This method ignores everything after the "at". Thus to match this warning you would have to call C. If you need to test for a warning at an exactly line, try something like C. Warn messages with a trailing newline (like C) don't produce the C message by Perl. Up to Test::Warn 0.30 such warning weren't supported by C. Starting with version 0.31 they are supported, but also marked as experimental. warning_is and warning_are are only aliases to the same method. So you also could write C or something similar. I decided to give two methods the same name to improve readability. A true value is returned if the test succeeds, false otherwise. The test name is optional, but recommended. =item warnings_are BLOCK ARRAYREF, TEST_NAME Tests to see that BLOCK gives exactly the specified warnings. The test fails if the warnings from BLOCK are not exactly the ones in ARRAYREF. If the ARRAYREF is equal to [], then the test succeeds if the BLOCK doesn't give any warning. Please read also the notes to warning_is as these methods are only aliases. If you want more than one test for carped warnings, try this: C ['c1','c2'];> or C ["Carp 1", "Carp 2"]}, "Warning 2"]>. Note that C<{carped => ...}> must always be a hash ref. =item warning_like BLOCK REGEXP, TEST_NAME Tests that BLOCK gives exactly one warning and it can be matched by the given regexp. If the string is undef, then the tests succeeds if the BLOCK doesn't give any warning. The REGEXP is matched against the whole warning line, which in general has the form "WARNING at __FILE__ line __LINE__". So you can check for a warning in the file Foo.pm on line 5 with C. I don't know whether it makes sense to do such a test :-( However, you should be prepared as a matching with 'at', 'file', '\d' or similar will always pass. Think to the qr/^foo/ if you want to test for warning "foo something" in file foo.pl. You can also write the regexp in a string as "/.../" instead of using the qr/.../ syntax. Note that the slashes are important in the string, as strings without slashes are reserved for warning categories (to match warning categories as can be seen in the perllexwarn man page). Similar to C, you can test for warnings via C with: C qr/bar called too early/i};> Similar to C/C, C and C are only aliases to the same methods. A true value is returned if the test succeeds, false otherwise. The test name is optional, but recommended. =item warning_like BLOCK STRING, TEST_NAME Tests whether a BLOCK gives exactly one warning of the passed category. The categories are grouped in a tree, like it is expressed in perllexwarn. Also see L. Thanks to the grouping in a tree, it's simple possible to test for an 'io' warning, instead for testing for a 'closed|exec|layer|newline|pipe|unopened' warning. Note, that warnings occurring at compile time, can only be caught in an eval block. So warning_like {eval q/"$x"; $x;/} [qw/void uninitialized/], "some warnings at compile time"; will work, while it wouldn't work without the eval. Note, that it isn't possible yet, to test for own categories, created with warnings::register. =item warnings_like BLOCK ARRAYREF, TEST_NAME Tests to see that BLOCK gives exactly the number of the specified warnings and all the warnings have to match in the defined order to the passed regexes. Please read also the notes to warning_like as these methods are only aliases. Similar to C, you can test for multiple warnings via C and for warning categories, too: warnings_like {foo()} [qr/bar warning/, qr/bar warning/, {carped => qr/bar warning/i}, 'io' ], "I hope, you'll never have to write a test for so many warnings :-)"; =item warnings_exist BLOCK STRING|ARRAYREF, TEST_NAME Same as warning_like, but will warn() all warnings that do not match the supplied regex/category, instead of registering an error. Use this test when you just want to make sure that specific warnings were generated, and couldn't care less if other warnings happened in the same block of code. warnings_exist {...} [qr/expected warning/], "Expected warning is thrown"; warnings_exist {...} ['uninitialized'], "Expected warning is thrown"; =back =head2 EXPORT C, C, C, C, C by default. =head1 BUGS AND LIMITATIONS Category check is done as qr/category_name/. In some case this works, like for category 'uninitialized'. For 'utf8' it does not work. Perl does not have a list of warnings, so it is not possible to generate one for Test::Warn. If you want to add a warning to a category, send a pull request. Modifications should be done to %warnings_in_category. You should look into perl source to check how warning is looking exactly. Please note that warnings with newlines inside are making a lot of trouble. The only sensible way to handle them is to use are the C or C methods. Background for these problems is that there is no really secure way to distinguish between warnings with newlines and a tracing stacktrace. If a method has it's own warn handler, overwriting C<$SIG{__WARN__}>, my test warning methods won't get these warnings. The C method isn't extremely tested. Please use this calling style with higher attention and tell me if you find a bug. =head1 TODO Improve this documentation. The code has some parts doubled - especially in the test scripts. This is really awkward and must be changed. Please feel free to suggest improvements. =head1 SEE ALSO Have a look to the similar modules: L, L. =head1 THANKS Many thanks to Adrian Howard, chromatic and Michael G. Schwern, who have given me a lot of ideas. =head1 AUTHOR Janek Schleicher, Ebigj AT kamelfreund.deE =head1 COPYRIGHT AND LICENSE Copyright 2002 by Janek Schleicher Copyright 2007-2014 by Alexandr Ciornii, L This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut package Test::Warn; use 5.006; use strict; use warnings; #use Array::Compare; use Sub::Uplevel 0.12; our $VERSION = '0.32'; require Exporter; our @ISA = qw(Exporter); our %EXPORT_TAGS = ( 'all' => [ qw( @EXPORT ) ] ); our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); our @EXPORT = qw( warning_is warnings_are warning_like warnings_like warnings_exist ); use Test::Builder; my $Tester = Test::Builder->new; { no warnings 'once'; *warning_is = *warnings_are; *warning_like = *warnings_like; } sub warnings_are (&$;$) { my $block = shift; my @exp_warning = map {_canonical_exp_warning($_)} _to_array_if_necessary( shift() || [] ); my $testname = shift; my @got_warning = (); local $SIG{__WARN__} = sub { my ($called_from) = caller(0); # to find out Carping methods push @got_warning, _canonical_got_warning($called_from, shift()); }; uplevel 1,$block; my $ok = _cmp_is( \@got_warning, \@exp_warning ); $Tester->ok( $ok, $testname ); $ok or _diag_found_warning(@got_warning), _diag_exp_warning(@exp_warning); return $ok; } sub warnings_like (&$;$) { my $block = shift; my @exp_warning = map {_canonical_exp_warning($_)} _to_array_if_necessary( shift() || [] ); my $testname = shift; my @got_warning = (); local $SIG{__WARN__} = sub { my ($called_from) = caller(0); # to find out Carping methods push @got_warning, _canonical_got_warning($called_from, shift()); }; uplevel 1,$block; my $ok = _cmp_like( \@got_warning, \@exp_warning ); $Tester->ok( $ok, $testname ); $ok or _diag_found_warning(@got_warning), _diag_exp_warning(@exp_warning); return $ok; } sub warnings_exist (&$;$) { my $block = shift; my @exp_warning = map {_canonical_exp_warning($_)} _to_array_if_necessary( shift() || [] ); my $testname = shift; my @got_warning = (); local $SIG{__WARN__} = sub { my ($called_from) = caller(0); # to find out Carping methods my $wrn_text=shift; my $wrn_rec=_canonical_got_warning($called_from, $wrn_text); foreach my $wrn (@exp_warning) { if (_cmp_got_to_exp_warning_like($wrn_rec,$wrn)) { push @got_warning, $wrn_rec; return; } } warn $wrn_text; }; uplevel 1,$block; my $ok = _cmp_like( \@got_warning, \@exp_warning ); $Tester->ok( $ok, $testname ); $ok or _diag_found_warning(@got_warning), _diag_exp_warning(@exp_warning); return $ok; } sub _to_array_if_necessary { return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]); } sub _canonical_got_warning { my ($called_from, $msg) = @_; my $warn_kind = $called_from eq 'Carp' ? 'carped' : 'warn'; my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included return {$warn_kind => $warning_stack[0]}; # return only the real message } sub _canonical_exp_warning { my ($exp) = @_; if (ref($exp) eq 'HASH') { # could be {carped => ...} my $to_carp = $exp->{carped} or return; # undefined message are ignored return (ref($to_carp) eq 'ARRAY') # is {carped => [ ..., ...] } ? map({ {carped => $_} } grep {defined $_} @$to_carp) : +{carped => $to_carp}; } return {warn => $exp}; } sub _cmp_got_to_exp_warning { my ($got_kind, $got_msg) = %{ shift() }; my ($exp_kind, $exp_msg) = %{ shift() }; return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped'); my $cmp; if ($exp_msg =~ /\n$/s) { $cmp = "$got_msg\n" eq $exp_msg; } else { $cmp = $got_msg =~ /^\Q$exp_msg\E at .+ line \d+\.?$/s; } return $cmp; } sub _cmp_got_to_exp_warning_like { my ($got_kind, $got_msg) = %{ shift() }; my ($exp_kind, $exp_msg) = %{ shift() }; return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped'); if (my $re = $Tester->maybe_regex($exp_msg)) { #qr// or '//' my $cmp = $got_msg =~ /$re/; return $cmp; } else { return Test::Warn::Categorization::warning_like_category($got_msg,$exp_msg); } } sub _cmp_is { my @got = @{ shift() }; my @exp = @{ shift() }; scalar @got == scalar @exp or return 0; my $cmp = 1; $cmp &&= _cmp_got_to_exp_warning($got[$_],$exp[$_]) for (0 .. $#got); return $cmp; } sub _cmp_like { my @got = @{ shift() }; my @exp = @{ shift() }; scalar @got == scalar @exp or return 0; my $cmp = 1; $cmp &&= _cmp_got_to_exp_warning_like($got[$_],$exp[$_]) for (0 .. $#got); return $cmp; } sub _diag_found_warning { foreach (@_) { if (ref($_) eq 'HASH') { ${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}") : $Tester->diag("found warning: ${$_}{warn}"); } else { $Tester->diag( "found warning: $_" ); } } $Tester->diag( "didn't find a warning" ) unless @_; } sub _diag_exp_warning { foreach (@_) { if (ref($_) eq 'HASH') { ${$_}{carped} ? $Tester->diag("expected to find carped warning: ${$_}{carped}") : $Tester->diag("expected to find warning: ${$_}{warn}"); } else { $Tester->diag( "expected to find warning: $_" ); } } $Tester->diag( "didn't expect to find a warning" ) unless @_; } package Test::Warn::Categorization; use Carp; my $bits = \%warnings::Bits; my @warnings = sort grep { my $warn_bits = $bits->{$_}; #!grep { $_ ne $warn_bits && ($_ & $warn_bits) eq $_ } values %$bits; } keys %$bits; my %warnings_in_category = ( 'utf8' => ['Wide character in \w+\b',], ); sub _warning_category_regexp { my $category = shift; my $category_bits = $bits->{$category} or return; my @category_warnings = grep { ($bits->{$_} & $category_bits) eq $bits->{$_} } @warnings; my @list = map { exists $warnings_in_category{$_}? (@{ $warnings_in_category{$_}}) : ($_) } @category_warnings; my $re = join "|", @list; return qr/$re/; } sub warning_like_category { my ($warning, $category) = @_; my $re = _warning_category_regexp($category) or carp("Unknown warning category '$category'"),return; my $ok = $warning =~ /$re/; return $ok; } 1; Test-Warn-0.32/Makefile.PL0000644000175000017500000000551713027230205014200 0ustar janekjanekuse 5.006; use strict; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile1( 'NAME' => 'Test::Warn', 'VERSION_FROM' => 'Warn.pm', # finds $VERSION 'ABSTRACT_FROM' => 'Warn.pm', # retrieve abstract from module 'PREREQ_PM' => { #'Array::Compare' => 0, #'Test::Exception' => 0, 'Test::Builder' => 0.13, 'Test::Builder::Tester' => 1.02, 'Sub::Uplevel' => 0.12, 'Carp' => 1.22, }, 'TEST_REQUIRES' => { 'File::Spec' => 0, 'Test::More' => 0, }, 'LICENSE' => 'perl', 'MIN_PERL_VERSION' => 5.006, AUTHOR => 'Alexandr Ciornii ', META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'git://github.com/hanfried/test-warn.git', web => 'https://github.com/hanfried/test-warn', }, }, keywords => ['testing', 'warnings'], }, PL_FILES => {}, $^O =~/win/i ? ( dist => { TAR => 'ptar', TARFLAGS => '-c -C -f', }, ) : (), ); sub WriteMakefile1 { #Compatibility code for old versions of EU::MM. Written by Alexandr Ciornii, version 2. Added by eumm-upgrade. my %params=@_; my $eumm_version=$ExtUtils::MakeMaker::VERSION; $eumm_version=eval $eumm_version; die "EXTRA_META is deprecated" if exists $params{EXTRA_META}; die "License not specified" if not exists $params{LICENSE}; if ($params{AUTHOR} and ref($params{AUTHOR}) eq 'ARRAY' and $eumm_version < 6.5705) { $params{META_ADD}->{author}=$params{AUTHOR}; $params{AUTHOR}=join(', ',@{$params{AUTHOR}}); } if ($params{TEST_REQUIRES} and $eumm_version < 6.64) { $params{BUILD_REQUIRES}={ %{$params{BUILD_REQUIRES} || {}} , %{$params{TEST_REQUIRES}} }; delete $params{TEST_REQUIRES}; } if ($params{BUILD_REQUIRES} and $eumm_version < 6.5503) { #EUMM 6.5502 has problems with BUILD_REQUIRES $params{PREREQ_PM}={ %{$params{PREREQ_PM} || {}} , %{$params{BUILD_REQUIRES}} }; delete $params{BUILD_REQUIRES}; } delete $params{CONFIGURE_REQUIRES} if $eumm_version < 6.52; delete $params{MIN_PERL_VERSION} if $eumm_version < 6.48; delete $params{META_MERGE} if $eumm_version < 6.46; delete $params{META_ADD} if $eumm_version < 6.46; delete $params{LICENSE} if $eumm_version < 6.31; WriteMakefile(%params); } Test-Warn-0.32/META.json0000644000175000017500000000271113027231037013644 0ustar janekjanek{ "abstract" : "Perl extension to test methods for warnings", "author" : [ "Alexandr Ciornii " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.1, CPAN::Meta::Converter version 2.150005", "keywords" : [ "testing", "warnings" ], "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-Warn", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Carp" : "1.22", "Sub::Uplevel" : "0.12", "Test::Builder" : "0.13", "Test::Builder::Tester" : "1.02", "perl" : "5.006" } }, "test" : { "requires" : { "File::Spec" : "0", "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/hanfried/test-warn.git", "web" : "https://github.com/hanfried/test-warn" } }, "version" : "0.32", "x_serialization_backend" : "JSON::PP version 2.27300" } Test-Warn-0.32/MANIFEST0000644000175000017500000000040113025221272013344 0ustar janekjanekChanges Makefile.PL MANIFEST README Warn.pm t/1.t t/warning_is.t t/warning_like.t t/warnings_are.t t/warnings_like.t t/warnings_exist.t t/warnings_exist1.pl t/carped.t META.yml Module meta-data (added by MakeMaker) META.json Test-Warn-0.32/README0000644000175000017500000000415613025221272013106 0ustar janekjanekTest/Warn version 0.30 ====================== INSTALLATION To install this module type the following: cpan Test::Warn or perl Makefile.PL make make test make install DEPENDENCIES This module requires these other modules and libraries: Test::Builder Sub::Uplevel File::Spec SYNOPSIS use Test::Warn; warning_is {foo(-dri => "/")} "Unknown Parameter 'dri'", "dri != dir gives warning"; warnings_are {bar(1,1)} ["Width very small", "Height very small"]; warning_is {add(2,2)} undef, "No warning to calc 2+2"; # or warnings_are {add(2,2)} [], "No warning to calc 2+2"; # what reads better :-) warning_like {foo(-dri => "/"} qr/unknown param/i, "an unknown parameter test"; warnings_like {bar(1,1)} [qr/width.*small/i, qr/height.*small/i]; warning_is {foo()} {carped => 'didn't found the right parameters'}; warnings_like {foo()} [qr/undefined/,qr/undefined/,{carped => qr/no result/i}]; warning_like {foo(undef)} 'uninitialized'; warning_like {bar(file => '/etc/passwd')} 'io'; warning_like {eval q/"$x"; $x;/} [qw/void uninitialized/], "some warnings at compile time"; DESCRIPTION This module provides a few convenience methods for testing warning based code. If you are not already familiar with the Test::More manpage now would be the time to go take a look. FUNCTIONS - OVERVIEW warning_is BLOCK STRING, TEST_NAME warnings_are BLOCK ARRAYREF, TEST_NAME warning_like BLOCK REGEXP, TEST_NAME warning_like BLOCK STRING, TEST_NAME warnings_like BLOCK ARRAYREF, TEST_NAME SEE ALSO Have a look to the similar Test::Exception module. THANKS Many thanks to Adrian Howard, chromatic and Michael G. Schwern, who all had given me a lot of ideas. AUTHOR Janek Schleicher, COPYRIGHT AND LICENSE Copyright 2002 by Janek Schleicher Copyright 2007-2014 by Alexandr Ciornii This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.