vcs.maemo.org Git - pkg-perl/blob - deb-src/libtest-warn-perl/libtest-warn-perl-0.11/t/warning_like.t

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