Test-Warn-0.37/0000755000175000017500000000000014275666164012252 5ustar janekjanekTest-Warn-0.37/t/0000755000175000017500000000000014275666164012515 5ustar janekjanekTest-Warn-0.37/t/warnings_like.t0000755000175000017500000000737213771327444015545 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.37/t/warning_like.t0000644000175000017500000000666513771320162015351 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.37/t/carped.t0000644000175000017500000000451013771320162014121 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.37/t/1.t0000644000175000017500000000076213771320162013030 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.37/t/warnings_are.t0000755000175000017500000000703413771320162015351 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.37/t/warnings_exist.t0000644000175000017500000000153514275664654015754 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', "warn_1 at $file line 17.", 'ok 2', 'ok 3', "warn_2 at $file line 26.", 'not ok 4', "warn_2 at $file line 32.", 'ok 5', "warn_2 at $file line 36.", 'not ok 6', qr/^Use of uninitialized value (?:\$a\s+)?in addition \(\+\) at \Q$file\E line 41\.$/, 'ok 7', '1..7' ); foreach my $i (0..$#expected) { if ($expected[$i]=~/^\(\?\^?\w*-?\w*:/) { like($lines[$i],$expected[$i]); } else { is($lines[$i],$expected[$i]); } } Test-Warn-0.37/t/warning_is.t0000644000175000017500000000633314275663645015050 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.37/t/warnings_exist1.pl0000644000175000017500000000105714275664654016204 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_1"; } [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.37/META.yml0000664000175000017500000000154014275666164013525 0ustar janekjanek--- abstract: 'Perl extension to test methods for warnings' author: - 'Janek Schleicher ' 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.34, CPAN::Meta::Converter version 2.150010' 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 provides: Test::Warn: file: Warn.pm version: '0.37' 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.37' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' Test-Warn-0.37/README0000644000175000017500000000421714275665326013135 0ustar janekjanekTest/Warn version 0.37 ====================== 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 have given me a lot of ideas. AUTHOR Janek Schleicher, COPYRIGHT AND LICENSE Copyright 2002 by Janek Schleicher Copyright 2007-2016 by Alexandr Ciornii Copyright 2016-2018 by Janek Schleicher This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Test-Warn-0.37/Changes0000644000175000017500000001210614275665170013541 0ustar janekjanekRevision history for Perl extension Test::Warn. 0.37 2022-08-13 Merged PR: - allow duplicate warnings when using warnings_exist https://github.com/hanfried/test-warn/pull/8 thx to Masahiro Honma (hiratara) 0.36 2018-06-23 - Added provide section to META.yml via changing Makefile.PL 0.35 2018-06-13 Merged several Pull Requests: - README clean-up: Assign Copyright to current author https://github.com/hanfried/test-warn/pull/6 thx to Andrew Grangaard (spazm) - Pod cleanup https://github.com/hanfried/test-warn/pull/5 thx to Andrew Grangaar (spazm) and Gabor Szabo (szabgab) - add missing comma https://github.com/hanfried/test-warn/pull/4 thx to Desmond Daignault (nawglan) - Nawglan/update meta yml https://github.com/hanfried/test-warn/pull/3 thx to Desmond Daignault (nawglan) and Karen Etheridge (karenetheridge) - create META.json so that perl Makefile.PL stops complaining https://github.com/hanfried/test-warn/pull/2 thx to Desmond Daignault (nawglan) and Karen Etheridge (karenetheridge) 0.34 2018-05-31 - Added a note that XS warnings might not be caught https://rt.cpan.org/Ticket/Display.html?id=42070&results=3c71d1b101a730e185691657f3b02f21 https://github.com/hanfried/test-warn/issues/1 - Removed TODO section - Updated Copyright section 0.33 2018-05-29 - Patch from Era Eriksson to clean up some manpage language Bug-Debian: #322351 https://rt.cpan.org/Ticket/Display.html?id=49519 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.37/Warn.pm0000644000175000017500000003712314275665306013522 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"; # whichever 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 L manpage now would be the time to go take a look. =head2 FUNCTIONS =over 4 =item B I 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 test succeeds if the BLOCK doesn't give any warning. Another way to say that there are no warnings in the block is: warnings_are {foo()} [], "no warnings" If you want to test for a warning given by Carp you have to write something like: warning_is {carp "msg"} {carped => '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<< warning_is {warn "foo"} "foo", "Foo succeeded" >>. If you need to test for a warning at an exact line, try something like: warning_like {warn "foo"} qr/at XYZ.dat line 5/ 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<< warning_is {warn "foo\n"} "foo\n" >>. Starting with version 0.31 they are supported, but also marked as experimental. L|/warning_is-BLOCK-STRING-TEST_NAME> and L|/warnings_are-BLOCK-ARRAYREF-TEST_NAME> are only aliases to the same method. So you also could write C<< warning_is {foo()} [], "no warning" >> 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 B I 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 C<< [] >>, then the test succeeds if the BLOCK doesn't give any warning. Please read also the notes to L|/warning_is-BLOCK-STRING-TEST_NAME> as these methods are only aliases. If you want more than one test for carped warnings, try this: warnings_are {carp "c1"; carp "c2"} {carped => ['c1','c2']; or warnings_are {foo()} ["Warning 1", {carped => ["Carp 1", "Carp 2"]}, "Warning 2"]; Note that C<< {carped => ...} >> must always be a hash ref. =item B I 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 C<< "WARNING at __FILE__ line __LINE__" >>. So you can check for a warning in the file C on line 5 with: warning_like {bar()} qr/at Foo.pm line 5/, "Testname" I don't know whether it makes sense to do such a test :-( However, you should be prepared as a matching with C<'at'>, C<'file'>, C<'\d'> or similar will always pass. Consider C<< qr/^foo/ >> if you want to test for warning C<"foo something"> in file F. You can also write the regexp in a string as C<"/.../"> instead of using the C<< 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 L<< C|/warning_is-BLOCK-STRING-TEST_NAME >> and L<< C|/warnings_are-BLOCK-ARRAYREF-TEST_NAME >> you can test for warnings via C with: warning_like {bar()} {carped => qr/bar called too early/i}; Similar to L<< C|/warning_is-BLOCK-STRING-TEST_NAME >> and L<< C|/warnings_are-BLOCK-ARRAYREF-TEST_NAME >>, L<< C|/warning_like-BLOCK-REGEXP-TEST_NAME >> and L<< C|/warnings_like-BLOCK-ARRAYREF-TEST_NAME >> 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 B I Tests whether a BLOCK gives exactly one warning of the passed category. The categories are grouped in a tree, like it is expressed in L. Also see L. Thanks to the grouping in a tree, it's possible to test simply for an 'io' warning, instead of 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 L. =item B I Tests to see that BLOCK gives exactly the number of the specified warnings, in the defined order. Please read also the notes to L<< C|/warning_like-BLOCK-REGEXP-TEST_NAME >> as these methods are only aliases. Similar to L<< C|/warnings_are-BLOCK-ARRAYREF-TEST_NAME >>, 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 B I Same as warning_like, but will C<< 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 C<< qr/category_name/ >>. In some case this works, like for category C<'uninitialized'>. For C<'utf8'> it does not work. Perl does not have a list of warnings, so it is not possible to generate one for C. If you want to add a warning to a category, send a pull request. Modifications should be done to C<< %warnings_in_category >>. You should look into perl source to check how warning is looking exactly. Please note that warnings with newlines inside are very awkward. The only sensible way to handle them is to use the C or C methods. The background is that there is no really safe way to distinguish between warnings with newlines and a stacktrace. If a method has its own warn handler, overwriting C<$SIG{__WARN__}>, my test warning methods won't get these warnings. The C method isn't fully tested. Please take note if you use this this calling style, and report any bugs you find. =head2 XS warnings As described in https://rt.cpan.org/Ticket/Display.html?id=42070&results=3c71d1b101a730e185691657f3b02f21 or https://github.com/hanfried/test-warn/issues/1 XS warnings might not be caught. =head1 SEE ALSO Have a look to the similar L module. 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 Copyright 2015-2018 by Janek Schleicher 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 Sub::Uplevel 0.12; our $VERSION = '0.37'; 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 = (); my $exp_idx = 0; 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); if ( $exp_idx < @exp_warning and _cmp_got_to_exp_warning_like($wrn_rec,$exp_warning[$exp_idx]) ) { push @got_warning, $wrn_rec; $exp_idx++; 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; # Create a warning name category (e.g. 'utf8') to map to a list of warnings. # The warnings are strings that will be OR'ed together into a # regular expression: qr/...|...|.../. 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.37/MANIFEST0000644000175000017500000000040113771320162013357 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.37/META.json0000664000175000017500000000306414275666164013700 0ustar janekjanek{ "abstract" : "Perl extension to test methods for warnings", "author" : [ "Janek Schleicher " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "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" } } }, "provides" : { "Test::Warn" : { "file" : "Warn.pm", "version" : "0.37" } }, "release_status" : "stable", "resources" : { "repository" : { "type" : "git", "url" : "git://github.com/hanfried/test-warn.git", "web" : "https://github.com/hanfried/test-warn" } }, "version" : "0.37", "x_serialization_backend" : "JSON::PP version 4.02" } Test-Warn-0.37/Makefile.PL0000644000175000017500000000610014275665217014217 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 ', AUTHOR => 'Janek Schleicher ', 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'], }, META_ADD => { provides => { 'Test::Warn' => { file => 'Warn.pm', version => '0.37', }, }, }, 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); }