3
Test::Warn - Perl extension to test methods for warnings
9
warning_is {foo(-dri => "/")} "Unknown Parameter 'dri'", "dri != dir gives warning";
10
warnings_are {bar(1,1)} ["Width very small", "Height very small"];
12
warning_is {add(2,2)} undef, "No warning to calc 2+2"; # or
13
warnings_are {add(2,2)} [], "No warning to calc 2+2"; # what reads better :-)
15
warning_like {foo(-dri => "/")} qr/unknown param/i, "an unknown parameter test";
16
warnings_like {bar(1,1)} [qr/width.*small/i, qr/height.*small/i];
18
warning_is {foo()} {carped => "didn't found the right parameters"};
19
warnings_like {foo()} [qr/undefined/,qr/undefined/,{carped => qr/no result/i}];
21
warning_like {foo(undef)} 'uninitialized';
22
warning_like {bar(file => '/etc/passwd')} 'io';
24
warning_like {eval q/"$x"; $x;/}
25
[qw/void uninitialized/],
26
"some warnings at compile time";
30
This module provides a few convenience methods for testing warning based code.
32
If you are not already familiar with the Test::More manpage
33
now would be the time to go take a look.
39
=item warning_is BLOCK STRING, TEST_NAME
41
Tests that BLOCK gives exactly the one specificated warning.
42
The test fails if the BLOCK warns more then one times or doesn't warn.
43
If the string is undef,
44
then the tests succeeds iff the BLOCK doesn't give any warning.
45
Another way to say that there aren't ary warnings in the block,
46
is C<warnings_are {foo()} [], "no warnings in">.
48
If you want to test for a warning given by carp,
49
You have to write something like:
50
C<warning_is {carp "msg"} {carped =E<gt> 'msg'}, "Test for a carped warning">.
52
if a "normal" warning is found instead of a "carped" one.
54
Note: C<warn "foo"> would print something like C<foo at -e line 1>.
55
This method ignores everything after the at. That means, to match this warning
56
you would have to call C<warning_is {warn "foo"} "foo", "Foo succeeded">.
57
If you need to test for a warning at an exactly line,
58
try better something like C<warning_like {warn "foo"} qr/at XYZ.dat line 5/>.
60
warning_is and warning_are are only aliases to the same method.
61
So you also could write
62
C<warning_is {foo()} [], "no warning"> or something similar.
63
I decided me to give two methods to have some better readable method names.
65
A true value is returned if the test succeeds, false otherwise.
67
The test name is optional, but recommended.
70
=item warnings_are BLOCK ARRAYREF, TEST_NAME
72
Tests to see that BLOCK gives exactly the specificated warnings.
73
The test fails if the BLOCK warns a different number than the size of the ARRAYREf
75
If the ARRAYREF is equal to [],
76
then the test succeeds iff the BLOCK doesn't give any warning.
78
Please read also the notes to warning_is as these methods are only aliases.
80
If you want more than one tests for carped warnings look that way:
81
C<warnings_are {carp "c1"; carp "c2"} {carped => ['c1','c2'];> or
82
C<warnings_are {foo()} ["Warning 1", {carped => ["Carp 1", "Carp 2"]}, "Warning 2"]>.
83
Note that C<{carped => ...}> has always to be a hash ref.
85
=item warning_like BLOCK REGEXP, TEST_NAME
87
Tests that BLOCK gives exactly one warning and it can be matched to the given regexp.
88
If the string is undef,
89
then the tests succeeds iff the BLOCK doesn't give any warning.
91
The REGEXP is matched after the whole warn line,
92
which consists in general of "WARNING at __FILE__ line __LINE__".
93
So you can check for a warning in at File Foo.pm line 5 with
94
C<warning_like {bar()} qr/at Foo.pm line 5/, "Testname">.
95
I don't know whether it's sensful to do such a test :-(
96
However, you should be prepared as a matching with 'at', 'file', '\d'
97
or similar will always pass.
98
Think to the qr/^foo/ if you want to test for warning "foo something" in file foo.pl.
100
You can also write the regexp in a string as "/.../"
101
instead of using the qr/.../ syntax.
102
Note that the slashes are important in the string,
103
as strings without slashes are reserved for warning categories
104
(to match warning categories as can be seen in the perllexwarn man page).
106
Similar to C<warning_is>,
107
you can test for warnings via C<carp> with:
108
C<warning_like {bar()} {carped => qr/bar called too early/i};>
110
Similar to C<warning_is>/C<warnings_are>,
111
C<warning_like> and C<warnings_like> are only aliases to the same methods.
113
A true value is returned if the test succeeds, false otherwise.
115
The test name is optional, but recommended.
117
=item warning_like BLOCK STRING, TEST_NAME
119
Tests whether a BLOCK gives exactly one warning of the passed category.
120
The categories are grouped in a tree,
121
like it is expressed in perllexwarn.
122
Note, that they have the hierarchical structure from perl 5.8.0,
123
wich has a little bit changed to 5.6.1 or earlier versions
124
(You can access the internal used tree with C<$Test::Warn::Categorization::tree>,
125
allthough I wouldn't recommend it)
127
Thanks to the grouping in a tree,
128
it's simple possible to test for an 'io' warning,
129
instead for testing for a 'closed|exec|layer|newline|pipe|unopened' warning.
131
Note, that warnings occuring at compile time,
132
can only be catched in an eval block. So
134
warning_like {eval q/"$x"; $x;/}
135
[qw/void uninitialized/],
136
"some warnings at compile time";
139
while it wouldn't work without the eval.
141
Note, that it isn't possible yet,
142
to test for own categories,
143
created with warnings::register.
145
=item warnings_like BLOCK ARRAYREF, TEST_NAME
147
Tests to see that BLOCK gives exactly the number of the specificated warnings
148
and all the warnings have to match in the defined order to the
151
Please read also the notes to warning_like as these methods are only aliases.
153
Similar to C<warnings_are>,
154
you can test for multiple warnings via C<carp>
155
and for warning categories, too:
157
warnings_like {foo()}
160
{carped => qr/bar warning/i},
163
"I hope, you'll never have to write a test for so many warnings :-)";
172
C<warnings_like> by default.
176
Please note that warnings with newlines inside are making a lot of trouble.
177
The only sensful way to handle them is to use are the C<warning_like> or
178
C<warnings_like> methods. Background for these problems is that there is no
179
really secure way to distinguish between warnings with newlines and a tracing
182
If a method has it's own warn handler,
183
overwriting C<$SIG{__WARN__}>,
184
my test warning methods won't get these warnings.
186
The C<warning_like BLOCK CATEGORY, TEST_NAME> method isn't extremely tested.
187
Please use this calling style with higher attention and
188
tell me if you find a bug.
192
Improve this documentation.
194
The code has some parts doubled - especially in the test scripts.
195
This is really awkward and has to be changed.
197
Please feel free to suggest me any improvements.
201
Have a look to the similar L<Test::Exception> module. Test::Trap
205
Many thanks to Adrian Howard, chromatic and Michael G. Schwern,
206
who have given me a lot of ideas.
210
Janek Schleicher, E<lt>bigj AT kamelfreund.deE<gt>
212
=head1 COPYRIGHT AND LICENSE
214
Copyright 2002 by Janek Schleicher
216
This library is free software; you can redistribute it and/or modify
217
it under the same terms as Perl itself.
229
use Sub::Uplevel 0.12;
231
our $VERSION = '0.11';
235
our @ISA = qw(Exporter);
237
our %EXPORT_TAGS = ( 'all' => [ qw(
241
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
244
warning_is warnings_are
245
warning_like warnings_like
249
my $Tester = Test::Builder->new;
251
*warning_is = *warnings_are;
253
sub warnings_are (&$;$) {
255
my @exp_warning = map {_canonical_exp_warning($_)}
256
_to_array_if_necessary( shift() || [] );
257
my $testname = shift;
258
my @got_warning = ();
259
local $SIG{__WARN__} = sub {
260
my ($called_from) = caller(0); # to find out Carping methods
261
push @got_warning, _canonical_got_warning($called_from, shift());
264
my $ok = _cmp_is( \@got_warning, \@exp_warning );
265
$Tester->ok( $ok, $testname );
266
$ok or _diag_found_warning(@got_warning),
267
_diag_exp_warning(@exp_warning);
271
*warning_like = *warnings_like;
273
sub warnings_like (&$;$) {
275
my @exp_warning = map {_canonical_exp_warning($_)}
276
_to_array_if_necessary( shift() || [] );
277
my $testname = shift;
278
my @got_warning = ();
279
local $SIG{__WARN__} = sub {
280
my ($called_from) = caller(0); # to find out Carping methods
281
push @got_warning, _canonical_got_warning($called_from, shift());
284
my $ok = _cmp_like( \@got_warning, \@exp_warning );
285
$Tester->ok( $ok, $testname );
286
$ok or _diag_found_warning(@got_warning),
287
_diag_exp_warning(@exp_warning);
292
sub _to_array_if_necessary {
293
return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]);
296
sub _canonical_got_warning {
297
my ($called_from, $msg) = @_;
298
my $warn_kind = $called_from eq 'Carp' ? 'carped' : 'warn';
299
my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included
300
return {$warn_kind => $warning_stack[0]}; # return only the real message
303
sub _canonical_exp_warning {
305
if (ref($exp) eq 'HASH') { # could be {carped => ...}
306
my $to_carp = $exp->{carped} or return; # undefined message are ignored
307
return (ref($to_carp) eq 'ARRAY') # is {carped => [ ..., ...] }
308
? map({ {carped => $_} } grep {defined $_} @$to_carp)
309
: +{carped => $to_carp};
311
return {warn => $exp};
314
sub _cmp_got_to_exp_warning {
315
my ($got_kind, $got_msg) = %{ shift() };
316
my ($exp_kind, $exp_msg) = %{ shift() };
317
return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
318
my $cmp = $got_msg =~ /^\Q$exp_msg\E at \S+ line \d+\.?$/;
322
sub _cmp_got_to_exp_warning_like {
323
my ($got_kind, $got_msg) = %{ shift() };
324
my ($exp_kind, $exp_msg) = %{ shift() };
325
return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped');
326
if (my $re = $Tester->maybe_regex($exp_msg)) {
327
my $cmp = $got_msg =~ /$re/;
330
return Test::Warn::Categorization::warning_like_category($got_msg,$exp_msg);
336
my @got = @{ shift() };
337
my @exp = @{ shift() };
338
scalar @got == scalar @exp or return 0;
340
$cmp &&= _cmp_got_to_exp_warning($got[$_],$exp[$_]) for (0 .. $#got);
345
my @got = @{ shift() };
346
my @exp = @{ shift() };
347
scalar @got == scalar @exp or return 0;
349
$cmp &&= _cmp_got_to_exp_warning_like($got[$_],$exp[$_]) for (0 .. $#got);
353
sub _diag_found_warning {
355
if (ref($_) eq 'HASH') {
356
${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}")
357
: $Tester->diag("found warning: ${$_}{warn}");
359
$Tester->diag( "found warning: $_" );
362
$Tester->diag( "didn't found a warning" ) unless @_;
365
sub _diag_exp_warning {
367
if (ref($_) eq 'HASH') {
368
${$_}{carped} ? $Tester->diag("expected to find carped warning: ${$_}{carped}")
369
: $Tester->diag("expected to find warning: ${$_}{warn}");
371
$Tester->diag( "expected to find warning: $_" );
374
$Tester->diag( "didn't expect to find a warning" ) unless @_;
377
package Tree::MyDAG_Node;
381
use base 'Tree::DAG_Node';
384
sub nice_lol_to_tree {
389
daughters => [_nice_lol_to_daughters(shift())]
393
sub _nice_lol_to_daughters {
394
my @names = @{ shift() };
396
my $last_daughter = undef;
398
if (ref($_) ne 'ARRAY') {
399
$last_daughter = Tree::DAG_Node->new({name => $_});
400
push @daughters, $last_daughter;
402
$last_daughter->add_daughters(_nice_lol_to_daughters($_));
409
my ($self, $search_name) = @_;
410
my $found_node = undef;
411
$self->walk_down({callback => sub {
413
$node->name eq $search_name and $found_node = $node,!"go on";
414
"go on with searching";
419
package Test::Warn::Categorization;
423
our $tree = Tree::MyDAG_Node->nice_lol_to_tree(
444
'severe' => [ 'debugging',
451
'syntax' => [ 'ambiguous',
473
sub _warning_category_regexp {
474
my $sub_tree = $tree->depthsearch(shift()) or return undef;
475
my $re = join "|", map {$_->name} $sub_tree->leaves_under;
476
return qr/(?=\w)$re/;
479
sub warning_like_category {
480
my ($warning, $category) = @_;
481
my $re = _warning_category_regexp($category) or
482
carp("Unknown warning category '$category'"),return undef;
483
my $ok = $warning =~ /$re/;
added
removed
t/lib/Test/Warn.pm
