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