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/;