| 1 | package Test; |
| 2 | |
| 3 | require 5.004; |
| 4 | |
| 5 | use strict; |
| 6 | |
| 7 | use Carp; |
| 8 | use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish |
| 9 | qw($TESTOUT $ONFAIL %todo %history $planned @FAILDETAIL)#private-ish |
| 10 | ); |
| 11 | |
| 12 | $VERSION = '1.18'; |
| 13 | require Exporter; |
| 14 | @ISA=('Exporter'); |
| 15 | |
| 16 | @EXPORT = qw(&plan &ok &skip); |
| 17 | @EXPORT_OK = qw($ntest $TESTOUT); |
| 18 | |
| 19 | $TestLevel = 0; # how many extra stack frames to skip |
| 20 | $|=1; |
| 21 | $ntest=1; |
| 22 | $TESTOUT = *STDOUT{IO}; |
| 23 | |
| 24 | # Use of this variable is strongly discouraged. It is set mainly to |
| 25 | # help test coverage analyzers know which test is running. |
| 26 | $ENV{REGRESSION_TEST} = $0; |
| 27 | |
| 28 | |
| 29 | =head1 NAME |
| 30 | |
| 31 | Test - provides a simple framework for writing test scripts |
| 32 | |
| 33 | =head1 SYNOPSIS |
| 34 | |
| 35 | use strict; |
| 36 | use Test; |
| 37 | |
| 38 | # use a BEGIN block so we print our plan before MyModule is loaded |
| 39 | BEGIN { plan tests => 14, todo => [3,4] } |
| 40 | |
| 41 | # load your module... |
| 42 | use MyModule; |
| 43 | |
| 44 | ok(0); # failure |
| 45 | ok(1); # success |
| 46 | |
| 47 | ok(0); # ok, expected failure (see todo list, above) |
| 48 | ok(1); # surprise success! |
| 49 | |
| 50 | ok(0,1); # failure: '0' ne '1' |
| 51 | ok('broke','fixed'); # failure: 'broke' ne 'fixed' |
| 52 | ok('fixed','fixed'); # success: 'fixed' eq 'fixed' |
| 53 | ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/ |
| 54 | |
| 55 | ok(sub { 1+1 }, 2); # success: '2' eq '2' |
| 56 | ok(sub { 1+1 }, 3); # failure: '2' ne '3' |
| 57 | ok(0, int(rand(2)); # (just kidding :-) |
| 58 | |
| 59 | my @list = (0,0); |
| 60 | ok @list, 3, "\@list=".join(',',@list); #extra diagnostics |
| 61 | ok 'segmentation fault', '/(?i)success/'; #regex match |
| 62 | |
| 63 | skip($feature_is_missing, ...); #do platform specific test |
| 64 | |
| 65 | =head1 DESCRIPTION |
| 66 | |
| 67 | B<STOP!> If you are writing a new test, we I<highly suggest> you use |
| 68 | the new Test::Simple and Test::More modules instead. |
| 69 | |
| 70 | L<Test::Harness|Test::Harness> expects to see particular output when it |
| 71 | executes tests. This module aims to make writing proper test scripts just |
| 72 | a little bit easier (and less error prone :-). |
| 73 | |
| 74 | |
| 75 | =head2 Functions |
| 76 | |
| 77 | All the following are exported by Test by default. |
| 78 | |
| 79 | =over 4 |
| 80 | |
| 81 | =item B<plan> |
| 82 | |
| 83 | BEGIN { plan %theplan; } |
| 84 | |
| 85 | This should be the first thing you call in your test script. It |
| 86 | declares your testing plan, how many there will be, if any of them |
| 87 | should be allowed to fail, etc... |
| 88 | |
| 89 | Typical usage is just: |
| 90 | |
| 91 | use Test; |
| 92 | BEGIN { plan tests => 23 } |
| 93 | |
| 94 | Things you can put in the plan: |
| 95 | |
| 96 | tests The number of tests in your script. |
| 97 | This means all ok() and skip() calls. |
| 98 | todo A reference to a list of tests which are allowed |
| 99 | to fail. See L</TODO TESTS>. |
| 100 | onfail A subroutine reference to be run at the end of |
| 101 | the test script should any of the tests fail. |
| 102 | See L</ONFAIL>. |
| 103 | |
| 104 | You must call plan() once and only once. |
| 105 | |
| 106 | =cut |
| 107 | |
| 108 | sub plan { |
| 109 | croak "Test::plan(%args): odd number of arguments" if @_ & 1; |
| 110 | croak "Test::plan(): should not be called more than once" if $planned; |
| 111 | |
| 112 | local($\, $,); # guard against -l and other things that screw with |
| 113 | # print |
| 114 | |
| 115 | my $max=0; |
| 116 | for (my $x=0; $x < @_; $x+=2) { |
| 117 | my ($k,$v) = @_[$x,$x+1]; |
| 118 | if ($k =~ /^test(s)?$/) { $max = $v; } |
| 119 | elsif ($k eq 'todo' or |
| 120 | $k eq 'failok') { for (@$v) { $todo{$_}=1; }; } |
| 121 | elsif ($k eq 'onfail') { |
| 122 | ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE"; |
| 123 | $ONFAIL = $v; |
| 124 | } |
| 125 | else { carp "Test::plan(): skipping unrecognized directive '$k'" } |
| 126 | } |
| 127 | my @todo = sort { $a <=> $b } keys %todo; |
| 128 | if (@todo) { |
| 129 | print $TESTOUT "1..$max todo ".join(' ', @todo).";\n"; |
| 130 | } else { |
| 131 | print $TESTOUT "1..$max\n"; |
| 132 | } |
| 133 | ++$planned; |
| 134 | |
| 135 | # Never used. |
| 136 | return undef; |
| 137 | } |
| 138 | |
| 139 | |
| 140 | =begin _private |
| 141 | |
| 142 | =item B<_to_value> |
| 143 | |
| 144 | my $value = _to_value($input); |
| 145 | |
| 146 | Converts an ok parameter to its value. Typically this just means |
| 147 | running it if its a code reference. You should run all inputed |
| 148 | values through this. |
| 149 | |
| 150 | =cut |
| 151 | |
| 152 | sub _to_value { |
| 153 | my ($v) = @_; |
| 154 | return (ref $v or '') eq 'CODE' ? $v->() : $v; |
| 155 | } |
| 156 | |
| 157 | =end _private |
| 158 | |
| 159 | =item B<ok> |
| 160 | |
| 161 | ok(1 + 1 == 2); |
| 162 | ok($have, $expect); |
| 163 | ok($have, $expect, $diagnostics); |
| 164 | |
| 165 | This is the reason for Test's existance. Its the basic function that |
| 166 | handles printing "ok" or "not ok" along with the current test number. |
| 167 | |
| 168 | In its most basic usage, it simply takes an expression. If its true, |
| 169 | the test passes, if false, the test fails. Simp. |
| 170 | |
| 171 | ok( 1 + 1 == 2 ); # ok if 1 + 1 == 2 |
| 172 | ok( $foo =~ /bar/ ); # ok if $foo contains 'bar' |
| 173 | ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns |
| 174 | # 'Armondo' |
| 175 | ok( @a == @b ); # ok if @a and @b are the same length |
| 176 | |
| 177 | The expression is evaluated in scalar context. So the following will |
| 178 | work: |
| 179 | |
| 180 | ok( @stuff ); # ok if @stuff has any elements |
| 181 | ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is |
| 182 | # defined. |
| 183 | |
| 184 | A special case is if the expression is a subroutine reference. In |
| 185 | that case, it is executed and its value (true or false) determines if |
| 186 | the test passes or fails. |
| 187 | |
| 188 | In its two argument form it compares the two values to see if they |
| 189 | equal (with C<eq>). |
| 190 | |
| 191 | ok( "this", "that" ); # not ok, 'this' ne 'that' |
| 192 | |
| 193 | If either is a subroutine reference, that is run and used as a |
| 194 | comparison. |
| 195 | |
| 196 | Should $expect either be a regex reference (ie. qr//) or a string that |
| 197 | looks like a regex (ie. '/foo/') ok() will perform a pattern match |
| 198 | against it rather than using eq. |
| 199 | |
| 200 | ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/ |
| 201 | ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/; |
| 202 | ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i; |
| 203 | |
| 204 | Finally, an optional set of $diagnostics will be printed should the |
| 205 | test fail. This should usually be some useful information about the |
| 206 | test pertaining to why it failed or perhaps a description of the test. |
| 207 | Or both. |
| 208 | |
| 209 | ok( grep($_ eq 'something unique', @stuff), 1, |
| 210 | "Something that should be unique isn't!\n". |
| 211 | '@stuff = '.join ', ', @stuff |
| 212 | ); |
| 213 | |
| 214 | Unfortunately, a diagnostic cannot be used with the single argument |
| 215 | style of ok(). |
| 216 | |
| 217 | All these special cases can cause some problems. See L</BUGS and CAVEATS>. |
| 218 | |
| 219 | =cut |
| 220 | |
| 221 | sub ok ($;$$) { |
| 222 | croak "ok: plan before you test!" if !$planned; |
| 223 | |
| 224 | local($\,$,); # guard against -l and other things that screw with |
| 225 | # print |
| 226 | |
| 227 | my ($pkg,$file,$line) = caller($TestLevel); |
| 228 | my $repetition = ++$history{"$file:$line"}; |
| 229 | my $context = ("$file at line $line". |
| 230 | ($repetition > 1 ? " fail \#$repetition" : '')); |
| 231 | my $ok=0; |
| 232 | my $result = _to_value(shift); |
| 233 | my ($expected,$diag,$isregex,$regex); |
| 234 | if (@_ == 0) { |
| 235 | $ok = $result; |
| 236 | } else { |
| 237 | $expected = _to_value(shift); |
| 238 | if (!defined $expected) { |
| 239 | $ok = !defined $result; |
| 240 | } elsif (!defined $result) { |
| 241 | $ok = 0; |
| 242 | } elsif ((ref($expected)||'') eq 'Regexp') { |
| 243 | $ok = $result =~ /$expected/; |
| 244 | $regex = $expected; |
| 245 | } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or |
| 246 | (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { |
| 247 | $ok = $result =~ /$regex/; |
| 248 | } else { |
| 249 | $ok = $result eq $expected; |
| 250 | } |
| 251 | } |
| 252 | my $todo = $todo{$ntest}; |
| 253 | if ($todo and $ok) { |
| 254 | $context .= ' TODO?!' if $todo; |
| 255 | print $TESTOUT "ok $ntest # ($context)\n"; |
| 256 | } else { |
| 257 | # Issuing two seperate prints() causes problems on VMS. |
| 258 | if (!$ok) { |
| 259 | print $TESTOUT "not ok $ntest\n"; |
| 260 | } |
| 261 | else { |
| 262 | print $TESTOUT "ok $ntest\n"; |
| 263 | } |
| 264 | |
| 265 | if (!$ok) { |
| 266 | my $detail = { 'repetition' => $repetition, 'package' => $pkg, |
| 267 | 'result' => $result, 'todo' => $todo }; |
| 268 | $$detail{expected} = $expected if defined $expected; |
| 269 | |
| 270 | # Get the user's diagnostic, protecting against multi-line |
| 271 | # diagnostics. |
| 272 | $diag = $$detail{diagnostic} = _to_value(shift) if @_; |
| 273 | $diag =~ s/\n/\n#/g if defined $diag; |
| 274 | |
| 275 | $context .= ' *TODO*' if $todo; |
| 276 | if (!defined $expected) { |
| 277 | if (!$diag) { |
| 278 | print $TESTOUT "# Failed test $ntest in $context\n"; |
| 279 | } else { |
| 280 | print $TESTOUT "# Failed test $ntest in $context: $diag\n"; |
| 281 | } |
| 282 | } else { |
| 283 | my $prefix = "Test $ntest"; |
| 284 | print $TESTOUT "# $prefix got: ". |
| 285 | (defined $result? "'$result'":'<UNDEF>')." ($context)\n"; |
| 286 | $prefix = ' ' x (length($prefix) - 5); |
| 287 | if (defined $regex) { |
| 288 | $expected = 'qr{'.$regex.'}'; |
| 289 | } |
| 290 | else { |
| 291 | $expected = "'$expected'"; |
| 292 | } |
| 293 | if (!$diag) { |
| 294 | print $TESTOUT "# $prefix Expected: $expected\n"; |
| 295 | } else { |
| 296 | print $TESTOUT "# $prefix Expected: $expected ($diag)\n"; |
| 297 | } |
| 298 | } |
| 299 | push @FAILDETAIL, $detail; |
| 300 | } |
| 301 | } |
| 302 | ++ $ntest; |
| 303 | $ok; |
| 304 | } |
| 305 | |
| 306 | sub skip ($;$$$) { |
| 307 | local($\, $,); # guard against -l and other things that screw with |
| 308 | # print |
| 309 | |
| 310 | my $whyskip = _to_value(shift); |
| 311 | if (!@_ or $whyskip) { |
| 312 | $whyskip = '' if $whyskip =~ m/^\d+$/; |
| 313 | $whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old |
| 314 | # versions required the reason |
| 315 | # to start with 'skip' |
| 316 | # We print in one shot for VMSy reasons. |
| 317 | my $ok = "ok $ntest # skip"; |
| 318 | $ok .= " $whyskip" if length $whyskip; |
| 319 | $ok .= "\n"; |
| 320 | print $TESTOUT $ok; |
| 321 | ++ $ntest; |
| 322 | return 1; |
| 323 | } else { |
| 324 | # backwards compatiblity (I think). skip() used to be |
| 325 | # called like ok(), which is weird. I haven't decided what to do with |
| 326 | # this yet. |
| 327 | # warn <<WARN if $^W; |
| 328 | #This looks like a skip() using the very old interface. Please upgrade to |
| 329 | #the documented interface as this has been deprecated. |
| 330 | #WARN |
| 331 | |
| 332 | local($TestLevel) = $TestLevel+1; #ignore this stack frame |
| 333 | return &ok(@_); |
| 334 | } |
| 335 | } |
| 336 | |
| 337 | =back |
| 338 | |
| 339 | =cut |
| 340 | |
| 341 | END { |
| 342 | $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; |
| 343 | } |
| 344 | |
| 345 | 1; |
| 346 | __END__ |
| 347 | |
| 348 | =head1 TEST TYPES |
| 349 | |
| 350 | =over 4 |
| 351 | |
| 352 | =item * NORMAL TESTS |
| 353 | |
| 354 | These tests are expected to succeed. If they don't something's |
| 355 | screwed up! |
| 356 | |
| 357 | =item * SKIPPED TESTS |
| 358 | |
| 359 | Skip is for tests that might or might not be possible to run depending |
| 360 | on the availability of platform specific features. The first argument |
| 361 | should evaluate to true (think "yes, please skip") if the required |
| 362 | feature is not available. After the first argument, skip works |
| 363 | exactly the same way as do normal tests. |
| 364 | |
| 365 | =item * TODO TESTS |
| 366 | |
| 367 | TODO tests are designed for maintaining an B<executable TODO list>. |
| 368 | These tests are expected NOT to succeed. If a TODO test does succeed, |
| 369 | the feature in question should not be on the TODO list, now should it? |
| 370 | |
| 371 | Packages should NOT be released with succeeding TODO tests. As soon |
| 372 | as a TODO test starts working, it should be promoted to a normal test |
| 373 | and the newly working feature should be documented in the release |
| 374 | notes or change log. |
| 375 | |
| 376 | =back |
| 377 | |
| 378 | =head1 ONFAIL |
| 379 | |
| 380 | BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } } |
| 381 | |
| 382 | While test failures should be enough, extra diagnostics can be |
| 383 | triggered at the end of a test run. C<onfail> is passed an array ref |
| 384 | of hash refs that describe each test failure. Each hash will contain |
| 385 | at least the following fields: C<package>, C<repetition>, and |
| 386 | C<result>. (The file, line, and test number are not included because |
| 387 | their correspondence to a particular test is tenuous.) If the test |
| 388 | had an expected value or a diagnostic string, these will also be |
| 389 | included. |
| 390 | |
| 391 | The B<optional> C<onfail> hook might be used simply to print out the |
| 392 | version of your package and/or how to report problems. It might also |
| 393 | be used to generate extremely sophisticated diagnostics for a |
| 394 | particularly bizarre test failure. However it's not a panacea. Core |
| 395 | dumps or other unrecoverable errors prevent the C<onfail> hook from |
| 396 | running. (It is run inside an C<END> block.) Besides, C<onfail> is |
| 397 | probably over-kill in most cases. (Your test code should be simpler |
| 398 | than the code it is testing, yes?) |
| 399 | |
| 400 | |
| 401 | =head1 BUGS and CAVEATS |
| 402 | |
| 403 | ok()'s special handling of subroutine references is an unfortunate |
| 404 | "feature" that can't be removed due to compatibility. |
| 405 | |
| 406 | ok()'s use of string eq can sometimes cause odd problems when comparing |
| 407 | numbers, especially if you're casting a string to a number: |
| 408 | |
| 409 | $foo = "1.0"; |
| 410 | ok( $foo, 1 ); # not ok, "1.0" ne 1 |
| 411 | |
| 412 | Your best bet is to use the single argument form: |
| 413 | |
| 414 | ok( $foo == 1 ); # ok "1.0" == 1 |
| 415 | |
| 416 | ok()'s special handing of strings which look like they might be |
| 417 | regexes can also cause unexpected behavior. An innocent: |
| 418 | |
| 419 | ok( $fileglob, '/path/to/some/*stuff/' ); |
| 420 | |
| 421 | will fail since Test.pm considers the second argument to a regex. |
| 422 | Again, best bet is to use the single argument form: |
| 423 | |
| 424 | ok( $fileglob eq '/path/to/some/*stuff/' ); |
| 425 | |
| 426 | |
| 427 | =head1 TODO |
| 428 | |
| 429 | Add todo(). |
| 430 | |
| 431 | Allow named tests. |
| 432 | |
| 433 | Implement noplan(). |
| 434 | |
| 435 | |
| 436 | =head1 SEE ALSO |
| 437 | |
| 438 | L<Test::Simple>, L<Test::More>, L<Test::Harness>, L<Devel::Cover> |
| 439 | |
| 440 | L<Test::Unit> is an interesting alternative testing library. |
| 441 | |
| 442 | L<Pod::Tests> and L<SelfTest> let you embed tests in code. |
| 443 | |
| 444 | |
| 445 | =head1 AUTHOR |
| 446 | |
| 447 | Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved. |
| 448 | Copyright (c) 2001 Michael G Schwern. |
| 449 | |
| 450 | Current maintainer, Michael G Schwern <schwern@pobox.com> |
| 451 | |
| 452 | This package is free software and is provided "as is" without express |
| 453 | or implied warranty. It may be used, redistributed and/or modified |
| 454 | under the terms of the Perl Artistic License (see |
| 455 | http://www.perl.com/perl/misc/Artistic.html) |
| 456 | |
| 457 | =cut |