t/lib/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 =head1 DESCRIPTION
  29
  30 This module provides a few convenience methods for testing warning based code.
  31
  32 If you are not already familiar with the Test::More manpage
  33 now would be the time to go take a look.
  34
  35 =head2 FUNCTIONS
  36
  37 =over 4
  38
  39 =item warning_is BLOCK STRING, TEST_NAME
  40
  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">.
  47
  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">.
  51 The test will fail,
  52 if a "normal" warning is found instead of a "carped" one.
  53
  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/>.
  59
  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.
  64
  65 A true value is returned if the test succeeds, false otherwise.
  66
  67 The test name is optional, but recommended.
  68
  69
  70 =item warnings_are BLOCK ARRAYREF, TEST_NAME
  71
  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
  74 would have expected.
  75 If the ARRAYREF is equal to [],
  76 then the test succeeds iff the BLOCK doesn't give any warning.
  77
  78 Please read also the notes to warning_is as these methods are only aliases.
  79
  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.
  84
  85 =item warning_like BLOCK REGEXP, TEST_NAME
  86
  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.
  90
  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.
  99
 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).
 105
 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};>
 109
 110 Similar to C<warning_is>/C<warnings_are>,
 111 C<warning_like> and C<warnings_like> are only aliases to the same methods.
 112
 113 A true value is returned if the test succeeds, false otherwise.
 114
 115 The test name is optional, but recommended.
 116
 117 =item warning_like BLOCK STRING, TEST_NAME
 118
 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)
 126
 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.
 130
 131 Note, that warnings occuring at compile time,
 132 can only be catched in an eval block. So
 133
 134   warning_like {eval q/"$x"; $x;/}
 135                [qw/void uninitialized/],
 136                "some warnings at compile time";
 137
 138 will work,
 139 while it wouldn't work without the eval.
 140
 141 Note, that it isn't possible yet,
 142 to test for own categories,
 143 created with warnings::register.
 144
 145 =item warnings_like BLOCK ARRAYREF, TEST_NAME
 146
 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
 149 passed regexes.
 150
 151 Please read also the notes to warning_like as these methods are only aliases.
 152
 153 Similar to C<warnings_are>,
 154 you can test for multiple warnings via C<carp>
 155 and for warning categories, too:
 156
 157   warnings_like {foo()}
 158                 [qr/bar warning/,
 159                  qr/bar warning/,
 160                  {carped => qr/bar warning/i},
 161                  'io'
 162                 ],
 163                 "I hope, you'll never have to write a test for so many warnings :-)";
 164
 165 =back
 166
 167 =head2 EXPORT
 168
 169 C<warning_is>,
 170 C<warnings_are>,
 171 C<warning_like>,
 172 C<warnings_like> by default.
 173
 174 =head1 BUGS
 175
 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
 180 stacktrace.
 181
 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.
 185
 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.
 189
 190 =head1 TODO
 191
 192 Improve this documentation.
 193
 194 The code has some parts doubled - especially in the test scripts.
 195 This is really awkward and has to be changed.
 196
 197 Please feel free to suggest me any improvements.
 198
 199 =head1 SEE ALSO
 200
 201 Have a look to the similar L<Test::Exception> module. Test::Trap
 202
 203 =head1 THANKS
 204
 205 Many thanks to Adrian Howard, chromatic and Michael G. Schwern,
 206 who have given me a lot of ideas.
 207
 208 =head1 AUTHOR
 209
 210 Janek Schleicher, E<lt>bigj AT kamelfreund.deE<gt>
 211
 212 =head1 COPYRIGHT AND LICENSE
 213
 214 Copyright 2002 by Janek Schleicher
 215
 216 This library is free software; you can redistribute it and/or modify
 217 it under the same terms as Perl itself.
 218
 219 =cut
 220
 221
 222 package Test::Warn;
 223
 224 use 5.006;
 225 use strict;
 226 use warnings;
 227
 228 use Array::Compare;
 229 use Sub::Uplevel 0.12;
 230
 231 our $VERSION = '0.11';
 232
 233 require Exporter;
 234
 235 our @ISA = qw(Exporter);
 236
 237 our %EXPORT_TAGS = ( 'all' => [ qw(
 238     @EXPORT
 239 ) ] );
 240
 241 our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );
 242
 243 our @EXPORT = qw(
 244     warning_is   warnings_are
 245     warning_like warnings_like
 246 );
 247
 248 use Test::Builder;
 249 my $Tester = Test::Builder->new;
 250
 251 *warning_is = *warnings_are;
 252
 253 sub warnings_are (&$;$) {
 254     my $block       = shift;
 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());
 262     };
 263     uplevel 1,$block;
 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);
 268     return $ok;
 269 }
 270
 271 *warning_like = *warnings_like;
 272
 273 sub warnings_like (&$;$) {
 274     my $block       = shift;
 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());
 282     };
 283     uplevel 1,$block;
 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);
 288     return $ok;
 289 }
 290
 291
 292 sub _to_array_if_necessary {
 293     return (ref($_[0]) eq 'ARRAY') ? @{$_[0]} : ($_[0]);
 294 }
 295
 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
 301 }
 302
 303 sub _canonical_exp_warning {
 304     my ($exp) = @_;
 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};
 310     }
 311     return {warn => $exp};
 312 }
 313
 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+\.?$/;
 319     return $cmp;
 320 }
 321
 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/;
 328         return $cmp;
 329     } else {
 330         return Test::Warn::Categorization::warning_like_category($got_msg,$exp_msg);
 331     }
 332 }
 333
 334
 335 sub _cmp_is {
 336     my @got  = @{ shift() };
 337     my @exp  = @{ shift() };
 338     scalar @got == scalar @exp or return 0;
 339     my $cmp = 1;
 340     $cmp &&= _cmp_got_to_exp_warning($got[$_],$exp[$_]) for (0 .. $#got);
 341     return $cmp;
 342 }
 343
 344 sub _cmp_like {
 345     my @got  = @{ shift() };
 346     my @exp  = @{ shift() };
 347     scalar @got == scalar @exp or return 0;
 348     my $cmp = 1;
 349     $cmp &&= _cmp_got_to_exp_warning_like($got[$_],$exp[$_]) for (0 .. $#got);
 350     return $cmp;
 351 }
 352
 353 sub _diag_found_warning {
 354     foreach (@_) {
 355         if (ref($_) eq 'HASH') {
 356             ${$_}{carped} ? $Tester->diag("found carped warning: ${$_}{carped}")
 357                           : $Tester->diag("found warning: ${$_}{warn}");
 358         } else {
 359             $Tester->diag( "found warning: $_" );
 360         }
 361     }
 362     $Tester->diag( "didn't found a warning" ) unless @_;
 363 }
 364
 365 sub _diag_exp_warning {
 366     foreach (@_) {
 367         if (ref($_) eq 'HASH') {
 368             ${$_}{carped} ? $Tester->diag("expected to find carped warning: ${$_}{carped}")
 369                           : $Tester->diag("expected to find warning: ${$_}{warn}");
 370         } else {
 371             $Tester->diag( "expected to find warning: $_" );
 372         }
 373     }
 374     $Tester->diag( "didn't expect to find a warning" ) unless @_;
 375 }
 376
 377 package Tree::MyDAG_Node;
 378
 379 use strict;
 380 use warnings;
 381 use base 'Tree::DAG_Node';
 382
 383
 384 sub nice_lol_to_tree {
 385     my $class = shift;
 386     $class->new(
 387     {
 388         name      => shift(),
 389         daughters => [_nice_lol_to_daughters(shift())]
 390     });
 391 }
 392
 393 sub _nice_lol_to_daughters {
 394     my @names = @{ shift() };
 395     my @daughters = ();
 396     my $last_daughter = undef;
 397     foreach (@names) {
 398         if (ref($_) ne 'ARRAY') {
 399             $last_daughter = Tree::DAG_Node->new({name => $_});
 400             push @daughters, $last_daughter;
 401         } else {
 402             $last_daughter->add_daughters(_nice_lol_to_daughters($_));
 403         }
 404     }
 405     return @daughters;
 406 }
 407
 408 sub depthsearch {
 409     my ($self, $search_name) = @_;
 410     my $found_node = undef;
 411     $self->walk_down({callback => sub {
 412         my $node = shift();
 413         $node->name eq $search_name and $found_node = $node,!"go on";
 414         "go on with searching";
 415     }});
 416     return $found_node;
 417 }
 418
 419 package Test::Warn::Categorization;
 420
 421 use Carp;
 422
 423 our $tree = Tree::MyDAG_Node->nice_lol_to_tree(
 424    all => [ 'closure',
 425             'deprecated',
 426             'exiting',
 427             'glob',
 428             'io'           => [ 'closed',
 429                                 'exec',
 430                                 'layer',
 431                                 'newline',
 432                                 'pipe',
 433                                 'unopened'
 434                               ],
 435             'misc',
 436             'numeric',
 437             'once',
 438             'overflow',
 439             'pack',
 440             'portable',
 441             'recursion',
 442             'redefine',
 443             'regexp',
 444             'severe'       => [ 'debugging',
 445                                 'inplace',
 446                                 'internal',
 447                                 'malloc'
 448                               ],
 449             'signal',
 450             'substr',
 451             'syntax'       => [ 'ambiguous',
 452                                 'bareword',
 453                                 'digit',
 454                                 'parenthesis',
 455                                 'precedence',
 456                                 'printf',
 457                                 'prototype',
 458                                 'qw',
 459                                 'reserved',
 460                                 'semicolon'
 461                               ],
 462             'taint',
 463             'threads',
 464             'uninitialized',
 465             'unpack',
 466             'untie',
 467             'utf8',
 468             'void',
 469             'y2k'
 470            ]
 471 );
 472
 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/;
 477 }
 478
 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/;
 484     return $ok;
 485 }
 486
 487 1;