1=head1 NAME 2 3Test::Warn - Perl extension to test methods for warnings 4 5=head1 SYNOPSIS 6 7 use Test::Warn; 8 9 warning_is {foo(-dri => "/")} "Unknown Parameter 'dri'", "dri != dir gives warning"; 10 warnings_are {bar(1,1)} ["Width very small", "Height very small"]; 11 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 :-) 14 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]; 17 18 warning_is {foo()} {carped => "didn't found the right parameters"}; 19 warnings_like {foo()} [qr/undefined/,qr/undefined/,{carped => qr/no result/i}]; 20 21 warning_like {foo(undef)} 'uninitialized'; 22 warning_like {bar(file => '/etc/passwd')} 'io'; 23 24 warning_like {eval q/"$x"; $x;/} 25 [qw/void uninitialized/], 26 "some warnings at compile time"; 27 28 warnings_exist {...} [qr/expected warning/], "Expected warning is thrown"; 29 30=head1 DESCRIPTION 31 32A good style of Perl programming calls for a lot of diverse regression tests. 33 34This module provides a few convenience methods for testing warning based code. 35 36If you are not already familiar with the Test::More manpage 37now would be the time to go take a look. 38 39=head2 FUNCTIONS 40 41=over 4 42 43=item warning_is BLOCK STRING, TEST_NAME 44 45Tests that BLOCK gives exactly the one specificated warning. 46The test fails if the BLOCK warns more then one times or doesn't warn. 47If the string is undef, 48then the tests succeeds if the BLOCK doesn't give any warning. 49Another way to say that there aren't any warnings in the block, 50is C<warnings_are {foo()} [], "no warnings in">. 51 52If you want to test for a warning given by carp, 53You have to write something like: 54C<warning_is {carp "msg"} {carped =E<gt> 'msg'}, "Test for a carped warning">. 55The test will fail, 56if a "normal" warning is found instead of a "carped" one. 57 58Note: C<warn "foo"> would print something like C<foo at -e line 1>. 59This method ignores everything after the at. That means, to match this warning 60you would have to call C<warning_is {warn "foo"} "foo", "Foo succeeded">. 61If you need to test for a warning at an exactly line, 62try better something like C<warning_like {warn "foo"} qr/at XYZ.dat line 5/>. 63 64warning_is and warning_are are only aliases to the same method. 65So you also could write 66C<warning_is {foo()} [], "no warning"> or something similar. 67I decided to give two methods to have some better readable method names. 68 69A true value is returned if the test succeeds, false otherwise. 70 71The test name is optional, but recommended. 72 73 74=item warnings_are BLOCK ARRAYREF, TEST_NAME 75 76Tests to see that BLOCK gives exactly the specificated warnings. 77The test fails if the BLOCK warns a different number than the size of the ARRAYREf 78would have expected. 79If the ARRAYREF is equal to [], 80then the test succeeds if the BLOCK doesn't give any warning. 81 82Please read also the notes to warning_is as these methods are only aliases. 83 84If you want more than one tests for carped warnings look that way: 85C<warnings_are {carp "c1"; carp "c2"} {carped => ['c1','c2'];> or 86C<warnings_are {foo()} ["Warning 1", {carped => ["Carp 1", "Carp 2"]}, "Warning 2"]>. 87Note that C<{carped => ...}> has always to be a hash ref. 88 89=item warning_like BLOCK REGEXP, TEST_NAME 90 91Tests that BLOCK gives exactly one warning and it can be matched to the given regexp. 92If the string is undef, 93then the tests succeeds iff the BLOCK doesn't give any warning. 94 95The REGEXP is matched after the whole warn line, 96which consists in general of "WARNING at __FILE__ line __LINE__". 97So you can check for a warning in at File Foo.pm line 5 with 98C<warning_like {bar()} qr/at Foo.pm line 5/, "Testname">. 99I don't know whether it's sensful to do such a test :-( 100However, you should be prepared as a matching with 'at', 'file', '\d' 101or similar will always pass. 102Think to the qr/^foo/ if you want to test for warning "foo something" in file foo.pl. 103 104You can also write the regexp in a string as "/.../" 105instead of using the qr/.../ syntax. 106Note that the slashes are important in the string, 107as strings without slashes are reserved for warning categories 108(to match warning categories as can be seen in the perllexwarn man page). 109 110Similar to C<warning_is>, 111you can test for warnings via C<carp> with: 112C<warning_like {bar()} {carped => qr/bar called too early/i};> 113 114Similar to C<warning_is>/C<warnings_are>, 115C<warning_like> and C<warnings_like> are only aliases to the same methods. 116 117A true value is returned if the test succeeds, false otherwise. 118 119The test name is optional, but recommended. 120 121=item warning_like BLOCK STRING, TEST_NAME 122 123Tests whether a BLOCK gives exactly one warning of the passed category. 124The categories are grouped in a tree, 125like it is expressed in perllexwarn. 126Note, that they have the hierarchical structure from perl 5.8.0, 127wich has a little bit changed to 5.6.1 or earlier versions 128(You can access the internal used tree with C<$Test::Warn::Categorization::tree>, 129although I wouldn't recommend it) 130 131Thanks to the grouping in a tree, 132it's simple possible to test for an 'io' warning, 133instead for testing for a 'closed|exec|layer|newline|pipe|unopened' warning. 134 135Note, that warnings occuring at compile time, 136can only be catched in an eval block. So 137 138 warning_like {eval q/"$x"; $x;/} 139 [qw/void uninitialized/], 140 "some warnings at compile time"; 141 142will work, 143while it wouldn't work without the eval. 144 145Note, that it isn't possible yet, 146to test for own categories, 147created with warnings::register. 148 149=item warnings_like BLOCK ARRAYREF, TEST_NAME 150 151Tests to see that BLOCK gives exactly the number of the specificated warnings 152and all the warnings have to match in the defined order to the 153passed regexes. 154 155Please read also the notes to warning_like as these methods are only aliases. 156 157Similar to C<warnings_are>, 158you can test for multiple warnings via C<carp> 159and for warning categories, too: 160 161 warnings_like {foo()} 162 [qr/bar warning/, 163 qr/bar warning/, 164 {carped => qr/bar warning/i}, 165 'io' 166 ], 167 "I hope, you'll never have to write a test for so many warnings :-)"; 168 169=item warnings_exist BLOCK STRING|ARRAYREF, TEST_NAME 170 171Same as warning_like, but will warn() all warnings that do not match the supplied regex/category, 172instead of registering an error. Use this test when you just want to make sure that specific 173warnings were generated, and couldn't care less if other warnings happened in the same block 174of code. 175 176 warnings_exist {...} [qr/expected warning/], "Expected warning is thrown"; 177 178 warnings_exist {...} ['uninitialized'], "Expected warning is thrown"; 179 180=back 181 182=head2 EXPORT 183 184C<warning_is>, 185C<warnings_are>, 186C<warning_like>, 187C<warnings_like>, 188C<warnings_exist> by default. 189 190=head1 BUGS 191 192Please note that warnings with newlines inside are making a lot of trouble. 193The only sensible way to handle them is to use are the C<warning_like> or 194C<warnings_like> methods. Background for these problems is that there is no 195really secure way to distinguish between warnings with newlines and a tracing 196stacktrace. 197 198If a method has it's own warn handler, 199overwriting C<$SIG{__WARN__}>, 200my test warning methods won't get these warnings. 201 202The C<warning_like BLOCK CATEGORY, TEST_NAME> method isn't extremely tested. 203Please use this calling style with higher attention and 204tell me if you find a bug. 205 206=head1 TODO 207 208Improve this documentation. 209 210The code has some parts doubled - especially in the test scripts. 211This is really awkward and has to be changed. 212 213Please feel free to suggest me any improvements. 214 215=head1 SEE ALSO 216 217Have a look to the similar L<Test::Exception> module. Test::Trap 218 219=head1 THANKS 220 221Many thanks to Adrian Howard, chromatic and Michael G. Schwern, 222who have given me a lot of ideas. 223 224=head1 AUTHOR 225 226Janek Schleicher, E<lt>bigj AT kamelfreund.deE<gt> 227 228=head1 COPYRIGHT AND LICENSE 229 230Copyright 2002 by Janek Schleicher 231 232Copyright 2007-2009 by Alexandr Ciornii, L<http://chorny.net/> 233 234This library is free software; you can redistribute it and/or modify 235it under the same terms as Perl itself. 236 237=cut 238 239 240package Test::Warn; 241 242use 5.006; 243use strict; 244use warnings; 245 246#use Array::Compare; 247use Sub::Uplevel 0.12; 248 249our $VERSION = '0.21'; 250 251require Exporter; 252 253our @ISA = qw(Exporter); 254 255our %EXPORT_TAGS = ( 'all' => [ qw( 256 @EXPORT 257) ] ); 258 259our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } ); 260 261our @EXPORT = qw( 262 warning_is warnings_are 263 warning_like warnings_like 264 warnings_exist 265); 266 267use Test::Builder; 268my $Tester = Test::Builder->new; 269 270{ 271no warnings 'once'; 272*warning_is = *warnings_are; 273*warning_like = *warnings_like; 274} 275 276sub warnings_are (&$;$) { 277 my $block = shift; 278 my @exp_warning = map {_canonical_exp_warning($_)} 279 _to_array_if_necessary( shift() || [] ); 280 my $testname = shift; 281 my @got_warning = (); 282 local $SIG{__WARN__} = sub { 283 my ($called_from) = caller(0); # to find out Carping methods 284 push @got_warning, _canonical_got_warning($called_from, shift()); 285 }; 286 uplevel 1,$block; 287 my $ok = _cmp_is( \@got_warning, \@exp_warning ); 288 $Tester->ok( $ok, $testname ); 289 $ok or _diag_found_warning(@got_warning), 290 _diag_exp_warning(@exp_warning); 291 return $ok; 292} 293 294 295sub warnings_like (&$;$) { 296 my $block = shift; 297 my @exp_warning = map {_canonical_exp_warning($_)} 298 _to_array_if_necessary( shift() || [] ); 299 my $testname = shift; 300 my @got_warning = (); 301 local $SIG{__WARN__} = sub { 302 my ($called_from) = caller(0); # to find out Carping methods 303 push @got_warning, _canonical_got_warning($called_from, shift()); 304 }; 305 uplevel 1,$block; 306 my $ok = _cmp_like( \@got_warning, \@exp_warning ); 307 $Tester->ok( $ok, $testname ); 308 $ok or _diag_found_warning(@got_warning), 309 _diag_exp_warning(@exp_warning); 310 return $ok; 311} 312 313sub warnings_exist (&$;$) { 314 my $block = shift; 315 my @exp_warning = map {_canonical_exp_warning($_)} 316 _to_array_if_necessary( shift() || [] ); 317 my $testname = shift; 318 my @got_warning = (); 319 local $SIG{__WARN__} = sub { 320 my ($called_from) = caller(0); # to find out Carping methods 321 my $wrn_text=shift; 322 my $wrn_rec=_canonical_got_warning($called_from, $wrn_text); 323 foreach my $wrn (@exp_warning) { 324 if (_cmp_got_to_exp_warning_like($wrn_rec,$wrn)) { 325 push @got_warning, $wrn_rec; 326 return; 327 } 328 } 329 warn $wrn_text; 330 }; 331 uplevel 1,$block; 332 my $ok = _cmp_like( \@got_warning, \@exp_warning ); 333 $Tester->ok( $ok, $testname ); 334 $ok or _diag_found_warning(@got_warning), 335 _diag_exp_warning(@exp_warning); 336 return $ok; 337} 338 339 340sub _to_array_if_necessary { 341 return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]); 342} 343 344sub _canonical_got_warning { 345 my ($called_from, $msg) = @_; 346 my $warn_kind = $called_from eq 'Carp' ? 'carped' : 'warn'; 347 my @warning_stack = split /\n/, $msg; # some stuff of uplevel is included 348 return {$warn_kind => $warning_stack[0]}; # return only the real message 349} 350 351sub _canonical_exp_warning { 352 my ($exp) = @_; 353 if (ref($exp) eq 'HASH') { # could be {carped => ...} 354 my $to_carp = $exp->{carped} or return; # undefined message are ignored 355 return (ref($to_carp) eq 'ARRAY') # is {carped => [ ..., ...] } 356 ? map({ {carped => $_} } grep {defined $_} @$to_carp) 357 : +{carped => $to_carp}; 358 } 359 return {warn => $exp}; 360} 361 362sub _cmp_got_to_exp_warning { 363 my ($got_kind, $got_msg) = %{ shift() }; 364 my ($exp_kind, $exp_msg) = %{ shift() }; 365 return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped'); 366 my $cmp = $got_msg =~ /^\Q$exp_msg\E at .+ line \d+\.?$/; 367 return $cmp; 368} 369 370sub _cmp_got_to_exp_warning_like { 371 my ($got_kind, $got_msg) = %{ shift() }; 372 my ($exp_kind, $exp_msg) = %{ shift() }; 373 return 0 if ($got_kind eq 'warn') && ($exp_kind eq 'carped'); 374 if (my $re = $Tester->maybe_regex($exp_msg)) { #qr// or '//' 375 my $cmp = $got_msg =~ /$re/; 376 return $cmp; 377 } else { 378 return Test::Warn::Categorization::warning_like_category($got_msg,$exp_msg); 379 } 380} 381 382 383sub _cmp_is { 384 my @got = @{ shift() }; 385 my @exp = @{ shift() }; 386 scalar @got == scalar @exp or return 0; 387 my $cmp = 1; 388 $cmp &&= _cmp_got_to_exp_warning($got[$_],$exp[$_]) for (0 .. $#got); 389 return $cmp; 390} 391 392sub _cmp_like { 393 my @got = @{ shift() }; 394 my @exp = @{ shift() }; 395 scalar @got == scalar @exp or return 0; 396 my $cmp = 1; 397 $cmp &&= _cmp_got_to_exp_warning_like($got[$_],$exp[$_]) for (0 .. $#got); 398 return $cmp; 399} 400 401sub _diag_found_warning { 402 foreach (@_) { 403 if (ref($_) eq 'HASH') { 404 ${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}") 405 : $Tester->diag("found warning: ${$_}{warn}"); 406 } else { 407 $Tester->diag( "found warning: $_" ); 408 } 409 } 410 $Tester->diag( "didn't found a warning" ) unless @_; 411} 412 413sub _diag_exp_warning { 414 foreach (@_) { 415 if (ref($_) eq 'HASH') { 416 ${$_}{carped} ? $Tester->diag("expected to find carped warning: ${$_}{carped}") 417 : $Tester->diag("expected to find warning: ${$_}{warn}"); 418 } else { 419 $Tester->diag( "expected to find warning: $_" ); 420 } 421 } 422 $Tester->diag( "didn't expect to find a warning" ) unless @_; 423} 424 425package Test::Warn::DAG_Node_Tree; 426 427use strict; 428use warnings; 429use base 'Tree::DAG_Node'; 430 431 432sub nice_lol_to_tree { 433 my $class = shift; 434 $class->new( 435 { 436 name => shift(), 437 daughters => [_nice_lol_to_daughters(shift())] 438 }); 439} 440 441sub _nice_lol_to_daughters { 442 my @names = @{ shift() }; 443 my @daughters = (); 444 my $last_daughter = undef; 445 foreach (@names) { 446 if (ref($_) ne 'ARRAY') { 447 $last_daughter = Tree::DAG_Node->new({name => $_}); 448 push @daughters, $last_daughter; 449 } else { 450 $last_daughter->add_daughters(_nice_lol_to_daughters($_)); 451 } 452 } 453 return @daughters; 454} 455 456sub depthsearch { 457 my ($self, $search_name) = @_; 458 my $found_node = undef; 459 $self->walk_down({callback => sub { 460 my $node = shift(); 461 $node->name eq $search_name and $found_node = $node,!"go on"; 462 "go on with searching"; 463 }}); 464 return $found_node; 465} 466 467package Test::Warn::Categorization; 468 469use Carp; 470 471our $tree = Test::Warn::DAG_Node_Tree->nice_lol_to_tree( 472 all => [ 'closure', 473 'deprecated', 474 'exiting', 475 'glob', 476 'io' => [ 'closed', 477 'exec', 478 'layer', 479 'newline', 480 'pipe', 481 'unopened' 482 ], 483 'misc', 484 'numeric', 485 'once', 486 'overflow', 487 'pack', 488 'portable', 489 'recursion', 490 'redefine', 491 'regexp', 492 'severe' => [ 'debugging', 493 'inplace', 494 'internal', 495 'malloc' 496 ], 497 'signal', 498 'substr', 499 'syntax' => [ 'ambiguous', 500 'bareword', 501 'digit', 502 'parenthesis', 503 'precedence', 504 'printf', 505 'prototype', 506 'qw', 507 'reserved', 508 'semicolon' 509 ], 510 'taint', 511 'threads', 512 'uninitialized', 513 'unpack', 514 'untie', 515 'utf8', 516 'void', 517 'y2k' 518 ] 519); 520 521sub _warning_category_regexp { 522 my $sub_tree = $tree->depthsearch(shift()) or return; 523 my $re = join "|", map {$_->name} $sub_tree->leaves_under; 524 return qr/(?=\w)$re/; 525} 526 527sub warning_like_category { 528 my ($warning, $category) = @_; 529 my $re = _warning_category_regexp($category) or 530 carp("Unknown warning category '$category'"),return; 531 my $ok = $warning =~ /$re/; 532 return $ok; 533} 534 5351; 536