1#!/usr/bin/perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 unshift @INC, '../blib/lib'; 6} 7 8use strict; 9use warnings; 10 11use Carp; 12 13#expected, warning text, expected, test name 14use constant TESTS =>( 15 ["ok", "my warning", "my", "standard warning to find"], 16 ["not ok", "my warning", "another", "another warning instead of my warning"], 17 ["not ok", "warning general not", "^(?!warning general)", "quite only a sub warning"], 18 ["not ok", undef, "a warning", "no warning, but expected one"], 19 ["not ok", "a warning", undef, "warning, but didn't expect one"], 20 ["ok", undef, undef, "no warning"], 21 ["ok", '$!"%&/()=', '\$\!\"\%\&\/\(\)\=', "warning with crazy letters"], 22 ["not ok", "warning 1|warning 2", "warning1", "more than one warning"] 23); 24use constant SUBTESTS_PER_TESTS => 12; 25 26use Test::Builder::Tester tests => TESTS() * SUBTESTS_PER_TESTS; 27#use Test::Exception; 28use Test::Warn; 29 30Test::Builder::Tester::color 'on'; 31 32use constant WARN_LINE => line_num +2; 33sub _make_warn { 34 warn $_ for grep $_, split m:\|:, (shift() || ""); 35} 36 37use constant CARP_LINE => line_num +2; 38sub _make_carp { 39 carp $_ for grep $_, split m:\|:, (shift() || ""); 40} 41 42use constant CARP_LEVELS => (0 .. 2); 43sub _create_exp_warning { 44 my ($carplevel, $warning) = @_; 45 return $warning if $carplevel == 0; 46 return {carped => $warning} if $carplevel == 1; 47 return {carped => [$warning]} if $carplevel == 2; 48} 49 50test_warning_like(@$_) foreach TESTS(); 51 52sub test_warning_like { 53 my ($ok, $msg, $exp_warning, $testname) = @_; 54 for my $carp (CARP_LEVELS) { 55 *_found_msg = $carp ? *_found_carp_msg : *_found_warn_msg; 56 *_exp_msg = $carp ? *_exp_carp_msg : *_exp_warn_msg; 57 *_make_warn_or_carp = $carp ? *_make_carp : *_make_warn; 58 for my $t (undef, $testname) { 59 my @regexes = $exp_warning ? (qr/$exp_warning/, "/$exp_warning/") 60 : (undef, undef); # simpler to count the tests 61 for my $regex (@regexes) { 62 test_out "$ok 1" . ($t ? " - $t" : ""); 63 if ($ok =~ /not/) { 64 test_fail +4; 65 test_diag _found_msg($_) for ($msg ? (split m-\|-, $msg) : $msg); 66 test_diag _exp_msg($regex); 67 } 68 warning_like {_make_warn_or_carp($msg)} _create_exp_warning($carp, $regex), $t; 69 test_test "$testname (with" . ($_ ? "" : "out") . " a testname)"; 70 } 71 } 72 } 73} 74 75sub _found_warn_msg { 76 defined($_[0]) 77 ? ( join " " => ("found warning:", 78 $_[0], 79 "at", 80 __FILE__, 81 "line", 82 WARN_LINE . ".") ) 83 : "didn't found a warning"; 84} 85 86sub _exp_warn_msg { 87 defined($_[0]) 88 ? "expected to find warning: $_[0]" 89 : "didn't expect to find a warning"; 90} 91 92sub _found_carp_msg { 93 defined($_[0]) 94 ? ( join " " => ("found carped warning:", 95 $_[0], 96 "at", 97 __FILE__, 98 "line", 99 CARP_LINE) ) # Note the difference, that carp msg 100 : "didn't found a warning"; # aren't finished by '.' 101} 102 103sub _exp_carp_msg { 104 defined($_[0]) 105 ? "expected to find carped warning: $_[0]" 106 : "didn't expect to find a warning"; 107} 108