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

   1 use strict;
   2 use warnings;
   3
   4 package Test::NoWarnings;
   5
   6 use Test::Builder;
   7
   8 use Test::NoWarnings::Warning;
   9
  10 my $Test = Test::Builder->new;
  11 my $PID = $$;
  12
  13 use Carp;
  14
  15 use vars qw(
  16         $VERSION @EXPORT_OK @ISA $do_end_test
  17 );
  18
  19 $VERSION = '0.084';
  20
  21 require Exporter;
  22 @ISA = qw( Exporter );
  23
  24 @EXPORT_OK = qw(
  25         clear_warnings had_no_warnings warnings
  26 );
  27
  28 my @warnings;
  29
  30 $SIG{__WARN__} = make_catcher(\@warnings);
  31
  32 $do_end_test = 0;
  33
  34 sub import
  35 {
  36         $do_end_test = 1;
  37
  38         goto &Exporter::import;
  39 }
  40
  41 # the END block must be after the "use Test::Builder" to make sure it runs
  42 # before Test::Builder's end block
  43 # only run the test if there have been other tests
  44 END {
  45         had_no_warnings() if $do_end_test;
  46 }
  47
  48 sub make_warning
  49 {
  50         local $SIG{__WARN__};
  51
  52         my $msg = shift;
  53
  54         my $warning = Test::NoWarnings::Warning->new;
  55
  56         $warning->setMessage($msg);
  57         $warning->fillTest($Test);
  58         $warning->fillTrace(__PACKAGE__);
  59
  60         $Carp::Internal{__PACKAGE__.""}++;
  61         local $Carp::CarpLevel = $Carp::CarpLevel + 1;
  62         $warning->fillCarp($msg);
  63         $Carp::Internal{__PACKAGE__.""}--;
  64
  65         return $warning;
  66 }
  67
  68 sub make_catcher
  69 {
  70         # this make a subroutine which can be used in $SIG{__WARN__}
  71         # it takes one argument, a ref to an array
  72         # it will push the details of the warning onto the end of the array.
  73
  74         my $array = shift;
  75
  76         return sub {
  77                 my $msg = shift;
  78
  79                 $Carp::Internal{__PACKAGE__.""}++;
  80                 push(@$array, make_warning($msg));
  81                 $Carp::Internal{__PACKAGE__.""}--;
  82
  83                 return $msg;
  84         };
  85 }
  86
  87 sub had_no_warnings
  88 {
  89         return 0 if $$ != $PID;
  90
  91         local $SIG{__WARN__};
  92         my $name = shift || "no warnings";
  93
  94         my $ok;
  95         my $diag;
  96         if (@warnings == 0)
  97         {
  98                 $ok = 1;
  99         }
 100         else
 101         {
 102                 $ok = 0;
 103                 $diag = "There were ".@warnings." warning(s)\n";
 104                 $diag .= join("----------\n", map { $_->toString } @warnings);
 105         }
 106
 107         $Test->ok($ok, $name) || $Test->diag($diag);
 108
 109         return $ok;
 110 }
 111
 112 sub clear_warnings
 113 {
 114         local $SIG{__WARN__};
 115         @warnings = ();
 116 }
 117
 118 sub warnings
 119 {
 120         local $SIG{__WARN__};
 121         return @warnings;
 122 }
 123
 124 sub builder
 125 {
 126         local $SIG{__WARN__};
 127         if (@_)
 128         {
 129                 $Test = shift;
 130         }
 131         return $Test;
 132 }
 133
 134 1;
 135
 136 __END__
 137
 138 =head1 NAME
 139
 140 Test::NoWarnings - Make sure you didn't emit any warnings while testing
 141
 142 =head1 SYNOPSIS
 143
 144 For scripts that have no plan
 145
 146   use Test::NoWarnings;
 147
 148 that's it, you don't need to do anything else
 149
 150 For scripts that look like
 151
 152   use Test::More tests => x;
 153
 154 change to
 155
 156   use Test::More tests => x + 1;
 157   use Test::NoWarnings;
 158
 159 =head1 DESCRIPTION
 160
 161 In general, your tests shouldn't produce warnings. This modules causes any
 162 warnings to be captured and stored. It automatically adds an extra test that
 163 will run when your script ends to check that there were no warnings. If
 164 there were any warings, the test will give a "not ok" and diagnostics of
 165 where, when and what the warning was, including a stack trace of what was
 166 going on when the it occurred.
 167
 168 If some of your tests B<are supposed to> produce warnings then you should be
 169 capturing and checking them with L<Test::Warn>, that way L<Test::NoWarnings>
 170 will not see them and so not complain.
 171
 172 The test is run by an END block in Test::NoWarnings. It will not be run when
 173 any forked children exit.
 174
 175 =head1 USAGE
 176
 177 Simply by using the module, you automatically get an extra test at the end
 178 of your script that checks that no warnings were emitted. So just stick
 179
 180   use Test::NoWarnings
 181
 182 at the top of your script and continue as normal.
 183
 184 If you want more control you can invoke the test manually at any time with
 185 C<had_no_warnings()>.
 186
 187 The warnings your test has generated so far are stored in an array. You can
 188 look inside and clear this whenever you want with C<warnings()> and
 189 C<clear_warnings()>, however, if you are doing this sort of thing then you
 190 probably want to use L<Test::Warn> in combination with L<Test::NoWarnings>.
 191
 192 =head1 USE vs REQUIRE
 193
 194 You will almost always want to do
 195
 196   use Test::NoWarnings
 197
 198 If you do a C<require> rather than a C<use>, then there will be no automatic
 199 test at the end of your script.
 200
 201 =head1 OUTPUT
 202
 203 If warning is captured during your test then the details will output as part
 204 of the diagnostics. You will get:
 205
 206 =over 2
 207
 208 =item o
 209
 210 the number and name of the test that was executed just before the warning
 211 (if no test had been executed these will be 0 and '')
 212
 213 =item o
 214
 215 the message passed to C<warn>,
 216
 217 =item o
 218
 219 a full dump of the stack when warn was called, courtesy of the C<Carp>
 220 module
 221
 222 =back
 223
 224 =head1 EXPORTABLE FUNCTIONS
 225
 226 =head2 had_no_warnings()
 227
 228 This checks that there have been warnings emitted by your test scripts.
 229 Usually you will not call this explicitly as it is called automatically when
 230 your script finishes.
 231
 232 =head2 clear_warnings()
 233
 234 This will clear the array of warnings that have been captured. If the array
 235 is empty then a call to C<had_no_warnings()> will produce a pass result.
 236
 237 =head2 warnings()
 238
 239 This will return the array of warnings captured so far. Each element of this
 240 array is an object containing information about the warning. The following
 241 methods are available on these object.
 242
 243 =over 2
 244
 245 =item *
 246
 247 $warn-E<gt>getMessage
 248
 249 Get the message that would been printed by the warning.
 250
 251 =item *
 252
 253 $warn-E<gt>getCarp
 254
 255 Get a stack trace of what was going on when the warning happened, this stack
 256 trace is just a string generated by the L<Carp> module.
 257
 258 =item *
 259
 260 $warn-E<gt>getTrace
 261
 262 Get a stack trace object generated by the L<Devel::StackTrace> module. This
 263 will return undef if L<Devel::StackTrace> is not installed.
 264
 265 =item *
 266
 267 $warn-E<gt>getTest
 268
 269 Get the number of the test that executed before the warning was emitted.
 270
 271 =item *
 272
 273 $warn-E<gt>getTestName
 274
 275 Get the name of the test that executed before the warning was emitted.
 276
 277 =back
 278
 279 =head1 PITFALLS
 280
 281 When counting your tests for the plan, don't forget to include the test that
 282 runs automatically when your script ends.
 283
 284 =head1 BUGS
 285
 286 None that I know of.
 287
 288 =head1 HISTORY
 289
 290 This was previously known as L<Test::Warn::None>
 291
 292 =head1 SEE ALSO
 293
 294 L<Test::Builder>, L<Test::Warn>
 295
 296 =head1 AUTHOR
 297
 298 Written by Fergal Daly <fergal@esatclear.ie>.
 299
 300 =head1 COPYRIGHT
 301
 302 Copyright 2003 by Fergal Daly E<lt>fergal@esatclear.ieE<gt>.
 303
 304 This program is free software and comes with no warranty. It is distributed
 305 under the LGPL license
 306
 307 See the file F<LGPL> included in this distribution or
 308 F<http://www.fsf.org/licenses/licenses.html>.
 309
 310 =cut