/t/carped.t

 1#!/usr/bin/perl
 2
 3use strict;
 4use warnings;
 5
 6use Carp;
 7
 8use Test::Builder::Tester tests => 6;
 9Test::Builder::Tester::color 'on';
10use Test::Warn;
11
12sub foo {
13    warn "Warning 1";
14    carp "Carping 2";
15    carp "Carping 3";
16    warn "Warning 4";
17}
18
19#use File::Spec;
20#my $tcarped = File::Spec->catfile('t','carped.t');
21#$tcarped =~ s/\\/\//g if $^O eq 'MSWin32';
22#also will not work on VMS
23my $tcarped = $0; #'t/carped.t';
24
25test_out "ok 1";
26warnings_like {foo()} [map {qr/$_/} (1 .. 4)];
27test_test "Warnings and Carpings mixed, asked only for like warnings";
28
29test_out "not ok 1";
30my @test_diag = (
31"found warning: Warning 1 at $tcarped line 13.",
32"found carped warning: Carping 2 at $tcarped line 14".($Carp::VERSION gt "1.24"?".":""),
33"found carped warning: Carping 3 at $tcarped line 15".($Carp::VERSION gt "1.24"?".":""),
34"found warning: Warning 4 at $tcarped line 16.",
35"expected to find carped warning: (?-xism:1)",
36"expected to find carped warning: (?-xism:2)",
37"expected to find carped warning: (?-xism:3)",
38"expected to find carped warning: (?-xism:4)",
39);
40if (qr/x/ =~ /\(\?\^/){ s/-xism/^/ for @test_diag }
41test_fail +2;
42test_diag @test_diag;
43warnings_like {foo()} [{carped => [map {qr/$_/} (1 .. 4)]}];
44test_test "Warnings and Carpings mixed, asked only for like carpings";
45
46test_out "ok 1";
47warnings_like {foo()} [qr/1/, {carped => [qr/2/, qr/3/]}, qr/4/];
48test_test "Warnings and Carpings mixed, asked for the right likes";
49
50my @msg = ("Warning 1", "Carping 2", "Carping 3", "Warning 4");
51test_out "ok 1";
52warnings_are {foo()} \@msg;
53test_test "Warnings and Carpings mixed, asked only for warnings";
54
55test_out "not ok 1";
56test_fail +10;
57test_diag 
58"found warning: Warning 1 at $tcarped line 13.",
59"found carped warning: Carping 2 at $tcarped line 14".($Carp::VERSION gt "1.24"?".":""),
60"found carped warning: Carping 3 at $tcarped line 15".($Carp::VERSION gt "1.24"?".":""),
61"found warning: Warning 4 at $tcarped line 16.",
62"expected to find carped warning: Warning 1",
63"expected to find carped warning: Carping 2",
64"expected to find carped warning: Carping 3",
65"expected to find carped warning: Warning 4";
66warnings_are {foo()} {carped => \@msg};
67test_test "Warnings and Carpings mixed, asked only for carpings";
68
69test_out "ok 1";
70warnings_are {foo()} [$msg[0], {carped => [@msg[1..2]]}, $msg[3]];
71test_test "Warnings and Carpings mixed, asked for the right ones";