local-lib5/lib/perl5/Test/Warn.pm

   1 =head1 NAME
   2
   3 Test::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
  32 A good style of Perl programming calls for a lot of diverse regression tests.
  33
  34 This module provides a few convenience methods for testing warning based code.
  35
  36 If you are not already familiar with the Test::More manpage
  37 now 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
  45 Tests that BLOCK gives exactly the one specificated warning.
  46 The test fails if the BLOCK warns more then one times or doesn't warn.
  47 If the string is undef,
  48 then the tests succeeds if the BLOCK doesn't give any warning.
  49 Another way to say that there aren't any warnings in the block,
  50 is C<warnings_are {foo()} [], "no warnings in">.
  51
  52 If you want to test for a warning given by carp,
  53 You have to write something like:
  54 C<warning_is {carp "msg"} {carped =E<gt> 'msg'}, "Test for a carped warning">.
  55 The test will fail,
  56 if a "normal" warning is found instead of a "carped" one.
  57
  58 Note: C<warn "foo"> would print something like C<foo at -e line 1>.
  59 This method ignores everything after the at. That means, to match this warning
  60 you would have to call C<warning_is {warn "foo"} "foo", "Foo succeeded">.
  61 If you need to test for a warning at an exactly line,
  62 try better something like C<warning_like {warn "foo"} qr/at XYZ.dat line 5/>.
  63
  64 warning_is and warning_are are only aliases to the same method.
  65 So you also could write
  66 C<warning_is {foo()} [], "no warning"> or something similar.
  67 I decided to give two methods to have some better readable method names.
  68
  69 A true value is returned if the test succeeds, false otherwise.
  70
  71 The test name is optional, but recommended.
  72
  73
  74 =item warnings_are BLOCK ARRAYREF, TEST_NAME
  75
  76 Tests to see that BLOCK gives exactly the specificated warnings.
  77 The test fails if the BLOCK warns a different number than the size of the ARRAYREf
  78 would have expected.
  79 If the ARRAYREF is equal to [],
  80 then the test succeeds if the BLOCK doesn't give any warning.
  81
  82 Please read also the notes to warning_is as these methods are only aliases.
  83
  84 If you want more than one tests for carped warnings look that way:
  85 C<warnings_are {carp "c1"; carp "c2"} {carped => ['c1','c2'];> or
  86 C<warnings_are {foo()} ["Warning 1", {carped => ["Carp 1", "Carp 2"]}, "Warning 2"]>.
  87 Note that C<{carped => ...}> has always to be a hash ref.
  88
  89 =item warning_like BLOCK REGEXP, TEST_NAME
  90
  91 Tests that BLOCK gives exactly one warning and it can be matched to the given regexp.
  92 If the string is undef,
  93 then the tests succeeds iff the BLOCK doesn't give any warning.
  94
  95 The REGEXP is matched after the whole warn line,
  96 which consists in general of "WARNING at __FILE__ line __LINE__".
  97 So you can check for a warning in at File Foo.pm line 5 with
  98 C<warning_like {bar()} qr/at Foo.pm line 5/, "Testname">.
  99 I don't know whether it's sensful to do such a test :-(
 100 However, you should be prepared as a matching with 'at', 'file', '\d'
 101 or similar will always pass.
 102 Think to the qr/^foo/ if you want to test for warning "foo something" in file foo.pl.
 103
 104 You can also write the regexp in a string as "/.../"
 105 instead of using the qr/.../ syntax.
 106 Note that the slashes are important in the string,
 107 as strings without slashes are reserved for warning categories
 108 (to match warning categories as can be seen in the perllexwarn man page).
 109
 110 Similar to C<warning_is>,
 111 you can test for warnings via C<carp> with:
 112 C<warning_like {bar()} {carped => qr/bar called too early/i};>
 113
 114 Similar to C<warning_is>/C<warnings_are>,
 115 C<warning_like> and C<warnings_like> are only aliases to the same methods.
 116
 117 A true value is returned if the test succeeds, false otherwise.
 118
 119 The test name is optional, but recommended.
 120
 121 =item warning_like BLOCK STRING, TEST_NAME
 122
 123 Tests whether a BLOCK gives exactly one warning of the passed category.
 124 The categories are grouped in a tree,
 125 like it is expressed in perllexwarn.
 126 Note, that they have the hierarchical structure from perl 5.8.0,
 127 wich 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>,
 129 although I wouldn't recommend it)
 130
 131 Thanks to the grouping in a tree,
 132 it's simple possible to test for an 'io' warning,
 133 instead for testing for a 'closed|exec|layer|newline|pipe|unopened' warning.
 134
 135 Note, that warnings occuring at compile time,
 136 can 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
 142 will work,
 143 while it wouldn't work without the eval.
 144
 145 Note, that it isn't possible yet,
 146 to test for own categories,
 147 created with warnings::register.
 148
 149 =item warnings_like BLOCK ARRAYREF, TEST_NAME
 150
 151 Tests to see that BLOCK gives exactly the number of the specificated warnings
 152 and all the warnings have to match in the defined order to the
 153 passed regexes.
 154
 155 Please read also the notes to warning_like as these methods are only aliases.
 156
 157 Similar to C<warnings_are>,
 158 you can test for multiple warnings via C<carp>
 159 and 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
 171 Same as warning_like, but will warn() all warnings that do not match the supplied regex/category,
 172 instead of registering an error. Use this test when you just want to make sure that specific
 173 warnings were generated, and couldn't care less if other warnings happened in the same block
 174 of 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
 184 C<warning_is>,
 185 C<warnings_are>,
 186 C<warning_like>,
 187 C<warnings_like>,
 188 C<warnings_exist> by default.
 189
 190 =head1 BUGS
 191
 192 Please note that warnings with newlines inside are making a lot of trouble.
 193 The only sensible way to handle them is to use are the C<warning_like> or
 194 C<warnings_like> methods. Background for these problems is that there is no
 195 really secure way to distinguish between warnings with newlines and a tracing
 196 stacktrace.
 197
 198 If a method has it's own warn handler,
 199 overwriting C<$SIG{__WARN__}>,
 200 my test warning methods won't get these warnings.
 201
 202 The C<warning_like BLOCK CATEGORY, TEST_NAME> method isn't extremely tested.
 203 Please use this calling style with higher attention and
 204 tell me if you find a bug.
 205
 206 =head1 TODO
 207
 208 Improve this documentation.
 209
 210 The code has some parts doubled - especially in the test scripts.
 211 This is really awkward and has to be changed.
 212
 213 Please feel free to suggest me any improvements.
 214
 215 =head1 SEE ALSO
 216
 217 Have a look to the similar L<Test::Exception> module. Test::Trap
 218
 219 =head1 THANKS
 220
 221 Many thanks to Adrian Howard, chromatic and Michael G. Schwern,
 222 who have given me a lot of ideas.
 223
 224 =head1 AUTHOR
 225
 226 Janek Schleicher, E<lt>bigj AT kamelfreund.deE<gt>
 227
 228 =head1 COPYRIGHT AND LICENSE
 229
 230 Copyright 2002 by Janek Schleicher
 231
 232 Copyright 2007-2009 by Alexandr Ciornii, L<http://chorny.net/>
 233
 234 This library is free software; you can redistribute it and/or modify
 235 it under the same terms as Perl itself.
 236
 237 =cut
 238
 239
 240 package Test::Warn;
 241
 242 use 5.006;
 243 use strict;
 244 use warnings;
 245
 246 #use Array::Compare;
 247 use Sub::Uplevel 0.12;
 248
 249 our $VERSION = '0.21';
 250
 251 require Exporter;
 252
 253 our @ISA = qw(Exporter);
 254
 255 our %EXPORT_TAGS = ( 'all' => [ qw(
 256     @EXPORT
 257 ) ] );
 258
 259 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
 260
 261 our @EXPORT = qw(
 262     warning_is   warnings_are
 263     warning_like warnings_like
 264     warnings_exist
 265 );
 266
 267 use Test::Builder;
 268 my $Tester = Test::Builder->new;
 269
 270 {
 271 no warnings 'once';
 272 *warning_is = *warnings_are;
 273 *warning_like = *warnings_like;
 274 }
 275
 276 sub 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
 295 sub 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
 313 sub 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
 340 sub _to_array_if_necessary {
 341     return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]);
 342 }
 343
 344 sub _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
 351 sub _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
 362 sub _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
 370 sub _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
 383 sub _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
 392 sub _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
 401 sub _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
 413 sub _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
 425 package Test::Warn::DAG_Node_Tree;
 426
 427 use strict;
 428 use warnings;
 429 use base 'Tree::DAG_Node';
 430
 431
 432 sub 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
 441 sub _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
 456 sub 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
 467 package Test::Warn::Categorization;
 468
 469 use Carp;
 470
 471 our $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
 521 sub _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
 527 sub 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
 535 1;