| 1 | |
| 2 | require 5.004; |
| 3 | package Test; |
| 4 | # Time-stamp: "2004-04-28 21:46:51 ADT" |
| 5 | |
| 6 | use strict; |
| 7 | |
| 8 | use Carp; |
| 9 | use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish |
| 10 | qw($TESTOUT $TESTERR %Program_Lines $told_about_diff |
| 11 | $ONFAIL %todo %history $planned @FAILDETAIL) #private-ish |
| 12 | ); |
| 13 | |
| 14 | # In case a test is run in a persistent environment. |
| 15 | sub _reset_globals { |
| 16 | %todo = (); |
| 17 | %history = (); |
| 18 | @FAILDETAIL = (); |
| 19 | $ntest = 1; |
| 20 | $TestLevel = 0; # how many extra stack frames to skip |
| 21 | $planned = 0; |
| 22 | } |
| 23 | |
| 24 | $VERSION = '1.25'; |
| 25 | require Exporter; |
| 26 | @ISA=('Exporter'); |
| 27 | |
| 28 | @EXPORT = qw(&plan &ok &skip); |
| 29 | @EXPORT_OK = qw($ntest $TESTOUT $TESTERR); |
| 30 | |
| 31 | $|=1; |
| 32 | $TESTOUT = *STDOUT{IO}; |
| 33 | $TESTERR = *STDERR{IO}; |
| 34 | |
| 35 | # Use of this variable is strongly discouraged. It is set mainly to |
| 36 | # help test coverage analyzers know which test is running. |
| 37 | $ENV{REGRESSION_TEST} = $0; |
| 38 | |
| 39 | |
| 40 | =head1 NAME |
| 41 | |
| 42 | Test - provides a simple framework for writing test scripts |
| 43 | |
| 44 | =head1 SYNOPSIS |
| 45 | |
| 46 | use strict; |
| 47 | use Test; |
| 48 | |
| 49 | # use a BEGIN block so we print our plan before MyModule is loaded |
| 50 | BEGIN { plan tests => 14, todo => [3,4] } |
| 51 | |
| 52 | # load your module... |
| 53 | use MyModule; |
| 54 | |
| 55 | # Helpful notes. All note-lines must start with a "#". |
| 56 | print "# I'm testing MyModule version $MyModule::VERSION\n"; |
| 57 | |
| 58 | ok(0); # failure |
| 59 | ok(1); # success |
| 60 | |
| 61 | ok(0); # ok, expected failure (see todo list, above) |
| 62 | ok(1); # surprise success! |
| 63 | |
| 64 | ok(0,1); # failure: '0' ne '1' |
| 65 | ok('broke','fixed'); # failure: 'broke' ne 'fixed' |
| 66 | ok('fixed','fixed'); # success: 'fixed' eq 'fixed' |
| 67 | ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/ |
| 68 | |
| 69 | ok(sub { 1+1 }, 2); # success: '2' eq '2' |
| 70 | ok(sub { 1+1 }, 3); # failure: '2' ne '3' |
| 71 | |
| 72 | my @list = (0,0); |
| 73 | ok @list, 3, "\@list=".join(',',@list); #extra notes |
| 74 | ok 'segmentation fault', '/(?i)success/'; #regex match |
| 75 | |
| 76 | skip( |
| 77 | $^O =~ m/MSWin/ ? "Skip if MSWin" : 0, # whether to skip |
| 78 | $foo, $bar # arguments just like for ok(...) |
| 79 | ); |
| 80 | skip( |
| 81 | $^O =~ m/MSWin/ ? 0 : "Skip unless MSWin", # whether to skip |
| 82 | $foo, $bar # arguments just like for ok(...) |
| 83 | ); |
| 84 | |
| 85 | =head1 DESCRIPTION |
| 86 | |
| 87 | This module simplifies the task of writing test files for Perl modules, |
| 88 | such that their output is in the format that |
| 89 | L<Test::Harness|Test::Harness> expects to see. |
| 90 | |
| 91 | =head1 QUICK START GUIDE |
| 92 | |
| 93 | To write a test for your new (and probably not even done) module, create |
| 94 | a new file called F<t/test.t> (in a new F<t> directory). If you have |
| 95 | multiple test files, to test the "foo", "bar", and "baz" feature sets, |
| 96 | then feel free to call your files F<t/foo.t>, F<t/bar.t>, and |
| 97 | F<t/baz.t> |
| 98 | |
| 99 | =head2 Functions |
| 100 | |
| 101 | This module defines three public functions, C<plan(...)>, C<ok(...)>, |
| 102 | and C<skip(...)>. By default, all three are exported by |
| 103 | the C<use Test;> statement. |
| 104 | |
| 105 | =over 4 |
| 106 | |
| 107 | =item C<plan(...)> |
| 108 | |
| 109 | BEGIN { plan %theplan; } |
| 110 | |
| 111 | This should be the first thing you call in your test script. It |
| 112 | declares your testing plan, how many there will be, if any of them |
| 113 | should be allowed to fail, and so on. |
| 114 | |
| 115 | Typical usage is just: |
| 116 | |
| 117 | use Test; |
| 118 | BEGIN { plan tests => 23 } |
| 119 | |
| 120 | These are the things that you can put in the parameters to plan: |
| 121 | |
| 122 | =over |
| 123 | |
| 124 | =item C<tests =E<gt> I<number>> |
| 125 | |
| 126 | The number of tests in your script. |
| 127 | This means all ok() and skip() calls. |
| 128 | |
| 129 | =item C<todo =E<gt> [I<1,5,14>]> |
| 130 | |
| 131 | A reference to a list of tests which are allowed to fail. |
| 132 | See L</TODO TESTS>. |
| 133 | |
| 134 | =item C<onfail =E<gt> sub { ... }> |
| 135 | |
| 136 | =item C<onfail =E<gt> \&some_sub> |
| 137 | |
| 138 | A subroutine reference to be run at the end of the test script, if |
| 139 | any of the tests fail. See L</ONFAIL>. |
| 140 | |
| 141 | =back |
| 142 | |
| 143 | You must call C<plan(...)> once and only once. You should call it |
| 144 | in a C<BEGIN {...}> block, like so: |
| 145 | |
| 146 | BEGIN { plan tests => 23 } |
| 147 | |
| 148 | =cut |
| 149 | |
| 150 | sub plan { |
| 151 | croak "Test::plan(%args): odd number of arguments" if @_ & 1; |
| 152 | croak "Test::plan(): should not be called more than once" if $planned; |
| 153 | |
| 154 | local($\, $,); # guard against -l and other things that screw with |
| 155 | # print |
| 156 | |
| 157 | _reset_globals(); |
| 158 | |
| 159 | _read_program( (caller)[1] ); |
| 160 | |
| 161 | my $max=0; |
| 162 | while (@_) { |
| 163 | my ($k,$v) = splice(@_, 0, 2); |
| 164 | if ($k =~ /^test(s)?$/) { $max = $v; } |
| 165 | elsif ($k eq 'todo' or |
| 166 | $k eq 'failok') { for (@$v) { $todo{$_}=1; }; } |
| 167 | elsif ($k eq 'onfail') { |
| 168 | ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE"; |
| 169 | $ONFAIL = $v; |
| 170 | } |
| 171 | else { carp "Test::plan(): skipping unrecognized directive '$k'" } |
| 172 | } |
| 173 | my @todo = sort { $a <=> $b } keys %todo; |
| 174 | if (@todo) { |
| 175 | print $TESTOUT "1..$max todo ".join(' ', @todo).";\n"; |
| 176 | } else { |
| 177 | print $TESTOUT "1..$max\n"; |
| 178 | } |
| 179 | ++$planned; |
| 180 | print $TESTOUT "# Running under perl version $] for $^O", |
| 181 | (chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n"; |
| 182 | |
| 183 | print $TESTOUT "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n" |
| 184 | if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber(); |
| 185 | |
| 186 | print $TESTOUT "# MacPerl version $MacPerl::Version\n" |
| 187 | if defined $MacPerl::Version; |
| 188 | |
| 189 | printf $TESTOUT |
| 190 | "# Current time local: %s\n# Current time GMT: %s\n", |
| 191 | scalar(localtime($^T)), scalar(gmtime($^T)); |
| 192 | |
| 193 | print $TESTOUT "# Using Test.pm version $VERSION\n"; |
| 194 | |
| 195 | # Retval never used: |
| 196 | return undef; |
| 197 | } |
| 198 | |
| 199 | sub _read_program { |
| 200 | my($file) = shift; |
| 201 | return unless defined $file and length $file |
| 202 | and -e $file and -f _ and -r _; |
| 203 | open(SOURCEFILE, "<$file") || return; |
| 204 | $Program_Lines{$file} = [<SOURCEFILE>]; |
| 205 | close(SOURCEFILE); |
| 206 | |
| 207 | foreach my $x (@{$Program_Lines{$file}}) |
| 208 | { $x =~ tr/\cm\cj\n\r//d } |
| 209 | |
| 210 | unshift @{$Program_Lines{$file}}, ''; |
| 211 | return 1; |
| 212 | } |
| 213 | |
| 214 | =begin _private |
| 215 | |
| 216 | =item B<_to_value> |
| 217 | |
| 218 | my $value = _to_value($input); |
| 219 | |
| 220 | Converts an C<ok> parameter to its value. Typically this just means |
| 221 | running it, if it's a code reference. You should run all inputted |
| 222 | values through this. |
| 223 | |
| 224 | =cut |
| 225 | |
| 226 | sub _to_value { |
| 227 | my ($v) = @_; |
| 228 | return ref $v eq 'CODE' ? $v->() : $v; |
| 229 | } |
| 230 | |
| 231 | sub _quote { |
| 232 | my $str = $_[0]; |
| 233 | return "<UNDEF>" unless defined $str; |
| 234 | $str =~ s/\\/\\\\/g; |
| 235 | $str =~ s/"/\\"/g; |
| 236 | $str =~ s/\a/\\a/g; |
| 237 | $str =~ s/[\b]/\\b/g; |
| 238 | $str =~ s/\e/\\e/g; |
| 239 | $str =~ s/\f/\\f/g; |
| 240 | $str =~ s/\n/\\n/g; |
| 241 | $str =~ s/\r/\\r/g; |
| 242 | $str =~ s/\t/\\t/g; |
| 243 | $str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg; |
| 244 | $str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg; |
| 245 | $str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg; |
| 246 | #if( $_[1] ) { |
| 247 | # substr( $str , 218-3 ) = "..." |
| 248 | # if length($str) >= 218 and !$ENV{PERL_TEST_NO_TRUNC}; |
| 249 | #} |
| 250 | return qq("$str"); |
| 251 | } |
| 252 | |
| 253 | |
| 254 | =end _private |
| 255 | |
| 256 | =item C<ok(...)> |
| 257 | |
| 258 | ok(1 + 1 == 2); |
| 259 | ok($have, $expect); |
| 260 | ok($have, $expect, $diagnostics); |
| 261 | |
| 262 | This function is the reason for C<Test>'s existence. It's |
| 263 | the basic function that |
| 264 | handles printing "C<ok>" or "C<not ok>", along with the |
| 265 | current test number. (That's what C<Test::Harness> wants to see.) |
| 266 | |
| 267 | In its most basic usage, C<ok(...)> simply takes a single scalar |
| 268 | expression. If its value is true, the test passes; if false, |
| 269 | the test fails. Examples: |
| 270 | |
| 271 | # Examples of ok(scalar) |
| 272 | |
| 273 | ok( 1 + 1 == 2 ); # ok if 1 + 1 == 2 |
| 274 | ok( $foo =~ /bar/ ); # ok if $foo contains 'bar' |
| 275 | ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns |
| 276 | # 'Armondo' |
| 277 | ok( @a == @b ); # ok if @a and @b are the same length |
| 278 | |
| 279 | The expression is evaluated in scalar context. So the following will |
| 280 | work: |
| 281 | |
| 282 | ok( @stuff ); # ok if @stuff has any elements |
| 283 | ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is |
| 284 | # defined. |
| 285 | |
| 286 | A special case is if the expression is a subroutine reference (in either |
| 287 | C<sub {...}> syntax or C<\&foo> syntax). In |
| 288 | that case, it is executed and its value (true or false) determines if |
| 289 | the test passes or fails. For example, |
| 290 | |
| 291 | ok( sub { # See whether sleep works at least passably |
| 292 | my $start_time = time; |
| 293 | sleep 5; |
| 294 | time() - $start_time >= 4 |
| 295 | }); |
| 296 | |
| 297 | In its two-argument form, C<ok(I<arg1>, I<arg2>)> compares the two |
| 298 | scalar values to see if they match. They match if both are undefined, |
| 299 | or if I<arg2> is a regex that matches I<arg1>, or if they compare equal |
| 300 | with C<eq>. |
| 301 | |
| 302 | # Example of ok(scalar, scalar) |
| 303 | |
| 304 | ok( "this", "that" ); # not ok, 'this' ne 'that' |
| 305 | ok( "", undef ); # not ok, "" is defined |
| 306 | |
| 307 | The second argument is considered a regex if it is either a regex |
| 308 | object or a string that looks like a regex. Regex objects are |
| 309 | constructed with the qr// operator in recent versions of perl. A |
| 310 | string is considered to look like a regex if its first and last |
| 311 | characters are "/", or if the first character is "m" |
| 312 | and its second and last characters are both the |
| 313 | same non-alphanumeric non-whitespace character. These regexp |
| 314 | |
| 315 | Regex examples: |
| 316 | |
| 317 | ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/ |
| 318 | ok( 'JaffO', 'm|Jaff|' ); # ok, 'JaffO' =~ m|Jaff| |
| 319 | ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/; |
| 320 | ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i; |
| 321 | |
| 322 | If either (or both!) is a subroutine reference, it is run and used |
| 323 | as the value for comparing. For example: |
| 324 | |
| 325 | ok sub { |
| 326 | open(OUT, ">x.dat") || die $!; |
| 327 | print OUT "\x{e000}"; |
| 328 | close OUT; |
| 329 | my $bytecount = -s 'x.dat'; |
| 330 | unlink 'x.dat' or warn "Can't unlink : $!"; |
| 331 | return $bytecount; |
| 332 | }, |
| 333 | 4 |
| 334 | ; |
| 335 | |
| 336 | The above test passes two values to C<ok(arg1, arg2)> -- the first |
| 337 | a coderef, and the second is the number 4. Before C<ok> compares them, |
| 338 | it calls the coderef, and uses its return value as the real value of |
| 339 | this parameter. Assuming that C<$bytecount> returns 4, C<ok> ends up |
| 340 | testing C<4 eq 4>. Since that's true, this test passes. |
| 341 | |
| 342 | Finally, you can append an optional third argument, in |
| 343 | C<ok(I<arg1>,I<arg2>, I<note>)>, where I<note> is a string value that |
| 344 | will be printed if the test fails. This should be some useful |
| 345 | information about the test, pertaining to why it failed, and/or |
| 346 | a description of the test. For example: |
| 347 | |
| 348 | ok( grep($_ eq 'something unique', @stuff), 1, |
| 349 | "Something that should be unique isn't!\n". |
| 350 | '@stuff = '.join ', ', @stuff |
| 351 | ); |
| 352 | |
| 353 | Unfortunately, a note cannot be used with the single argument |
| 354 | style of C<ok()>. That is, if you try C<ok(I<arg1>, I<note>)>, then |
| 355 | C<Test> will interpret this as C<ok(I<arg1>, I<arg2>)>, and probably |
| 356 | end up testing C<I<arg1> eq I<arg2>> -- and that's not what you want! |
| 357 | |
| 358 | All of the above special cases can occasionally cause some |
| 359 | problems. See L</BUGS and CAVEATS>. |
| 360 | |
| 361 | =cut |
| 362 | |
| 363 | # A past maintainer of this module said: |
| 364 | # <<ok(...)'s special handling of subroutine references is an unfortunate |
| 365 | # "feature" that can't be removed due to compatibility.>> |
| 366 | # |
| 367 | |
| 368 | sub ok ($;$$) { |
| 369 | croak "ok: plan before you test!" if !$planned; |
| 370 | |
| 371 | local($\,$,); # guard against -l and other things that screw with |
| 372 | # print |
| 373 | |
| 374 | my ($pkg,$file,$line) = caller($TestLevel); |
| 375 | my $repetition = ++$history{"$file:$line"}; |
| 376 | my $context = ("$file at line $line". |
| 377 | ($repetition > 1 ? " fail \#$repetition" : '')); |
| 378 | |
| 379 | # Are we comparing two values? |
| 380 | my $compare = 0; |
| 381 | |
| 382 | my $ok=0; |
| 383 | my $result = _to_value(shift); |
| 384 | my ($expected, $isregex, $regex); |
| 385 | if (@_ == 0) { |
| 386 | $ok = $result; |
| 387 | } else { |
| 388 | $compare = 1; |
| 389 | $expected = _to_value(shift); |
| 390 | if (!defined $expected) { |
| 391 | $ok = !defined $result; |
| 392 | } elsif (!defined $result) { |
| 393 | $ok = 0; |
| 394 | } elsif (ref($expected) eq 'Regexp') { |
| 395 | $ok = $result =~ /$expected/; |
| 396 | $regex = $expected; |
| 397 | } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or |
| 398 | (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) { |
| 399 | $ok = $result =~ /$regex/; |
| 400 | } else { |
| 401 | $ok = $result eq $expected; |
| 402 | } |
| 403 | } |
| 404 | my $todo = $todo{$ntest}; |
| 405 | if ($todo and $ok) { |
| 406 | $context .= ' TODO?!' if $todo; |
| 407 | print $TESTOUT "ok $ntest # ($context)\n"; |
| 408 | } else { |
| 409 | # Issuing two seperate prints() causes problems on VMS. |
| 410 | if (!$ok) { |
| 411 | print $TESTOUT "not ok $ntest\n"; |
| 412 | } |
| 413 | else { |
| 414 | print $TESTOUT "ok $ntest\n"; |
| 415 | } |
| 416 | |
| 417 | $ok or _complain($result, $expected, |
| 418 | { |
| 419 | 'repetition' => $repetition, 'package' => $pkg, |
| 420 | 'result' => $result, 'todo' => $todo, |
| 421 | 'file' => $file, 'line' => $line, |
| 422 | 'context' => $context, 'compare' => $compare, |
| 423 | @_ ? ('diagnostic' => _to_value(shift)) : (), |
| 424 | }); |
| 425 | |
| 426 | } |
| 427 | ++ $ntest; |
| 428 | $ok; |
| 429 | } |
| 430 | |
| 431 | |
| 432 | sub _complain { |
| 433 | my($result, $expected, $detail) = @_; |
| 434 | $$detail{expected} = $expected if defined $expected; |
| 435 | |
| 436 | # Get the user's diagnostic, protecting against multi-line |
| 437 | # diagnostics. |
| 438 | my $diag = $$detail{diagnostic}; |
| 439 | $diag =~ s/\n/\n#/g if defined $diag; |
| 440 | |
| 441 | $$detail{context} .= ' *TODO*' if $$detail{todo}; |
| 442 | if (!$$detail{compare}) { |
| 443 | if (!$diag) { |
| 444 | print $TESTERR "# Failed test $ntest in $$detail{context}\n"; |
| 445 | } else { |
| 446 | print $TESTERR "# Failed test $ntest in $$detail{context}: $diag\n"; |
| 447 | } |
| 448 | } else { |
| 449 | my $prefix = "Test $ntest"; |
| 450 | |
| 451 | print $TESTERR "# $prefix got: " . _quote($result) . |
| 452 | " ($$detail{context})\n"; |
| 453 | $prefix = ' ' x (length($prefix) - 5); |
| 454 | my $expected_quoted = (defined $$detail{regex}) |
| 455 | ? 'qr{'.($$detail{regex}).'}' : _quote($expected); |
| 456 | |
| 457 | print $TESTERR "# $prefix Expected: $expected_quoted", |
| 458 | $diag ? " ($diag)" : (), "\n"; |
| 459 | |
| 460 | _diff_complain( $result, $expected, $detail, $prefix ) |
| 461 | if defined($expected) and 2 < ($expected =~ tr/\n//); |
| 462 | } |
| 463 | |
| 464 | if(defined $Program_Lines{ $$detail{file} }[ $$detail{line} ]) { |
| 465 | print $TESTERR |
| 466 | "# $$detail{file} line $$detail{line} is: $Program_Lines{ $$detail{file} }[ $$detail{line} ]\n" |
| 467 | if $Program_Lines{ $$detail{file} }[ $$detail{line} ] |
| 468 | =~ m/[^\s\#\(\)\{\}\[\]\;]/; # Otherwise it's uninformative |
| 469 | |
| 470 | undef $Program_Lines{ $$detail{file} }[ $$detail{line} ]; |
| 471 | # So we won't repeat it. |
| 472 | } |
| 473 | |
| 474 | push @FAILDETAIL, $detail; |
| 475 | return; |
| 476 | } |
| 477 | |
| 478 | |
| 479 | |
| 480 | sub _diff_complain { |
| 481 | my($result, $expected, $detail, $prefix) = @_; |
| 482 | return _diff_complain_external(@_) if $ENV{PERL_TEST_DIFF}; |
| 483 | return _diff_complain_algdiff(@_) |
| 484 | if eval { require Algorithm::Diff; Algorithm::Diff->VERSION(1.15); 1; }; |
| 485 | |
| 486 | $told_about_diff++ or print $TESTERR <<"EOT"; |
| 487 | # $prefix (Install the Algorithm::Diff module to have differences in multiline |
| 488 | # $prefix output explained. You might also set the PERL_TEST_DIFF environment |
| 489 | # $prefix variable to run a diff program on the output.) |
| 490 | EOT |
| 491 | ; |
| 492 | return; |
| 493 | } |
| 494 | |
| 495 | |
| 496 | |
| 497 | sub _diff_complain_external { |
| 498 | my($result, $expected, $detail, $prefix) = @_; |
| 499 | my $diff = $ENV{PERL_TEST_DIFF} || die "WHAAAA?"; |
| 500 | |
| 501 | require File::Temp; |
| 502 | my($got_fh, $got_filename) = File::Temp::tempfile("test-got-XXXXX"); |
| 503 | my($exp_fh, $exp_filename) = File::Temp::tempfile("test-exp-XXXXX"); |
| 504 | unless ($got_fh && $exp_fh) { |
| 505 | warn "Can't get tempfiles"; |
| 506 | return; |
| 507 | } |
| 508 | |
| 509 | print $got_fh $result; |
| 510 | print $exp_fh $expected; |
| 511 | if (close($got_fh) && close($exp_fh)) { |
| 512 | my $diff_cmd = "$diff $exp_filename $got_filename"; |
| 513 | print $TESTERR "#\n# $prefix $diff_cmd\n"; |
| 514 | if (open(DIFF, "$diff_cmd |")) { |
| 515 | local $_; |
| 516 | while (<DIFF>) { |
| 517 | print $TESTERR "# $prefix $_"; |
| 518 | } |
| 519 | close(DIFF); |
| 520 | } |
| 521 | else { |
| 522 | warn "Can't run diff: $!"; |
| 523 | } |
| 524 | } else { |
| 525 | warn "Can't write to tempfiles: $!"; |
| 526 | } |
| 527 | unlink($got_filename); |
| 528 | unlink($exp_filename); |
| 529 | return; |
| 530 | } |
| 531 | |
| 532 | |
| 533 | |
| 534 | sub _diff_complain_algdiff { |
| 535 | my($result, $expected, $detail, $prefix) = @_; |
| 536 | |
| 537 | my @got = split(/^/, $result); |
| 538 | my @exp = split(/^/, $expected); |
| 539 | |
| 540 | my $diff_kind; |
| 541 | my @diff_lines; |
| 542 | |
| 543 | my $diff_flush = sub { |
| 544 | return unless $diff_kind; |
| 545 | |
| 546 | my $count_lines = @diff_lines; |
| 547 | my $s = $count_lines == 1 ? "" : "s"; |
| 548 | my $first_line = $diff_lines[0][0] + 1; |
| 549 | |
| 550 | print $TESTERR "# $prefix "; |
| 551 | if ($diff_kind eq "GOT") { |
| 552 | print $TESTERR "Got $count_lines extra line$s at line $first_line:\n"; |
| 553 | for my $i (@diff_lines) { |
| 554 | print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n"; |
| 555 | } |
| 556 | } elsif ($diff_kind eq "EXP") { |
| 557 | if ($count_lines > 1) { |
| 558 | my $last_line = $diff_lines[-1][0] + 1; |
| 559 | print $TESTERR "Lines $first_line-$last_line are"; |
| 560 | } |
| 561 | else { |
| 562 | print $TESTERR "Line $first_line is"; |
| 563 | } |
| 564 | print $TESTERR " missing:\n"; |
| 565 | for my $i (@diff_lines) { |
| 566 | print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n"; |
| 567 | } |
| 568 | } elsif ($diff_kind eq "CH") { |
| 569 | if ($count_lines > 1) { |
| 570 | my $last_line = $diff_lines[-1][0] + 1; |
| 571 | print $TESTERR "Lines $first_line-$last_line are"; |
| 572 | } |
| 573 | else { |
| 574 | print $TESTERR "Line $first_line is"; |
| 575 | } |
| 576 | print $TESTERR " changed:\n"; |
| 577 | for my $i (@diff_lines) { |
| 578 | print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n"; |
| 579 | print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n"; |
| 580 | } |
| 581 | } |
| 582 | |
| 583 | # reset |
| 584 | $diff_kind = undef; |
| 585 | @diff_lines = (); |
| 586 | }; |
| 587 | |
| 588 | my $diff_collect = sub { |
| 589 | my $kind = shift; |
| 590 | &$diff_flush() if $diff_kind && $diff_kind ne $kind; |
| 591 | $diff_kind = $kind; |
| 592 | push(@diff_lines, [@_]); |
| 593 | }; |
| 594 | |
| 595 | |
| 596 | Algorithm::Diff::traverse_balanced( |
| 597 | \@got, \@exp, |
| 598 | { |
| 599 | DISCARD_A => sub { &$diff_collect("GOT", @_) }, |
| 600 | DISCARD_B => sub { &$diff_collect("EXP", @_) }, |
| 601 | CHANGE => sub { &$diff_collect("CH", @_) }, |
| 602 | MATCH => sub { &$diff_flush() }, |
| 603 | }, |
| 604 | ); |
| 605 | &$diff_flush(); |
| 606 | |
| 607 | return; |
| 608 | } |
| 609 | |
| 610 | |
| 611 | |
| 612 | |
| 613 | #~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~ |
| 614 | |
| 615 | |
| 616 | =item C<skip(I<skip_if_true>, I<args...>)> |
| 617 | |
| 618 | This is used for tests that under some conditions can be skipped. It's |
| 619 | basically equivalent to: |
| 620 | |
| 621 | if( $skip_if_true ) { |
| 622 | ok(1); |
| 623 | } else { |
| 624 | ok( args... ); |
| 625 | } |
| 626 | |
| 627 | ...except that the C<ok(1)> emits not just "C<ok I<testnum>>" but |
| 628 | actually "C<ok I<testnum> # I<skip_if_true_value>>". |
| 629 | |
| 630 | The arguments after the I<skip_if_true> are what is fed to C<ok(...)> if |
| 631 | this test isn't skipped. |
| 632 | |
| 633 | Example usage: |
| 634 | |
| 635 | my $if_MSWin = |
| 636 | $^O =~ m/MSWin/ ? 'Skip if under MSWin' : ''; |
| 637 | |
| 638 | # A test to be skipped if under MSWin (i.e., run except under MSWin) |
| 639 | skip($if_MSWin, thing($foo), thing($bar) ); |
| 640 | |
| 641 | Or, going the other way: |
| 642 | |
| 643 | my $unless_MSWin = |
| 644 | $^O =~ m/MSWin/ ? '' : 'Skip unless under MSWin'; |
| 645 | |
| 646 | # A test to be skipped unless under MSWin (i.e., run only under MSWin) |
| 647 | skip($unless_MSWin, thing($foo), thing($bar) ); |
| 648 | |
| 649 | The tricky thing to remember is that the first parameter is true if |
| 650 | you want to I<skip> the test, not I<run> it; and it also doubles as a |
| 651 | note about why it's being skipped. So in the first codeblock above, read |
| 652 | the code as "skip if MSWin -- (otherwise) test whether C<thing($foo)> is |
| 653 | C<thing($bar)>" or for the second case, "skip unless MSWin...". |
| 654 | |
| 655 | Also, when your I<skip_if_reason> string is true, it really should (for |
| 656 | backwards compatibility with older Test.pm versions) start with the |
| 657 | string "Skip", as shown in the above examples. |
| 658 | |
| 659 | Note that in the above cases, C<thing($foo)> and C<thing($bar)> |
| 660 | I<are> evaluated -- but as long as the C<skip_if_true> is true, |
| 661 | then we C<skip(...)> just tosses out their value (i.e., not |
| 662 | bothering to treat them like values to C<ok(...)>. But if |
| 663 | you need to I<not> eval the arguments when skipping the |
| 664 | test, use |
| 665 | this format: |
| 666 | |
| 667 | skip( $unless_MSWin, |
| 668 | sub { |
| 669 | # This code returns true if the test passes. |
| 670 | # (But it doesn't even get called if the test is skipped.) |
| 671 | thing($foo) eq thing($bar) |
| 672 | } |
| 673 | ); |
| 674 | |
| 675 | or even this, which is basically equivalent: |
| 676 | |
| 677 | skip( $unless_MSWin, |
| 678 | sub { thing($foo) }, sub { thing($bar) } |
| 679 | ); |
| 680 | |
| 681 | That is, both are like this: |
| 682 | |
| 683 | if( $unless_MSWin ) { |
| 684 | ok(1); # but it actually appends "# $unless_MSWin" |
| 685 | # so that Test::Harness can tell it's a skip |
| 686 | } else { |
| 687 | # Not skipping, so actually call and evaluate... |
| 688 | ok( sub { thing($foo) }, sub { thing($bar) } ); |
| 689 | } |
| 690 | |
| 691 | =cut |
| 692 | |
| 693 | sub skip ($;$$$) { |
| 694 | local($\, $,); # guard against -l and other things that screw with |
| 695 | # print |
| 696 | |
| 697 | my $whyskip = _to_value(shift); |
| 698 | if (!@_ or $whyskip) { |
| 699 | $whyskip = '' if $whyskip =~ m/^\d+$/; |
| 700 | $whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old |
| 701 | # versions required the reason |
| 702 | # to start with 'skip' |
| 703 | # We print in one shot for VMSy reasons. |
| 704 | my $ok = "ok $ntest # skip"; |
| 705 | $ok .= " $whyskip" if length $whyskip; |
| 706 | $ok .= "\n"; |
| 707 | print $TESTOUT $ok; |
| 708 | ++ $ntest; |
| 709 | return 1; |
| 710 | } else { |
| 711 | # backwards compatiblity (I think). skip() used to be |
| 712 | # called like ok(), which is weird. I haven't decided what to do with |
| 713 | # this yet. |
| 714 | # warn <<WARN if $^W; |
| 715 | #This looks like a skip() using the very old interface. Please upgrade to |
| 716 | #the documented interface as this has been deprecated. |
| 717 | #WARN |
| 718 | |
| 719 | local($TestLevel) = $TestLevel+1; #to ignore this stack frame |
| 720 | return &ok(@_); |
| 721 | } |
| 722 | } |
| 723 | |
| 724 | =back |
| 725 | |
| 726 | =cut |
| 727 | |
| 728 | END { |
| 729 | $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL; |
| 730 | } |
| 731 | |
| 732 | 1; |
| 733 | __END__ |
| 734 | |
| 735 | =head1 TEST TYPES |
| 736 | |
| 737 | =over 4 |
| 738 | |
| 739 | =item * NORMAL TESTS |
| 740 | |
| 741 | These tests are expected to succeed. Usually, most or all of your tests |
| 742 | are in this category. If a normal test doesn't succeed, then that |
| 743 | means that something is I<wrong>. |
| 744 | |
| 745 | =item * SKIPPED TESTS |
| 746 | |
| 747 | The C<skip(...)> function is for tests that might or might not be |
| 748 | possible to run, depending |
| 749 | on the availability of platform-specific features. The first argument |
| 750 | should evaluate to true (think "yes, please skip") if the required |
| 751 | feature is I<not> available. After the first argument, C<skip(...)> works |
| 752 | exactly the same way as C<ok(...)> does. |
| 753 | |
| 754 | =item * TODO TESTS |
| 755 | |
| 756 | TODO tests are designed for maintaining an B<executable TODO list>. |
| 757 | These tests are I<expected to fail.> If a TODO test does succeed, |
| 758 | then the feature in question shouldn't be on the TODO list, now |
| 759 | should it? |
| 760 | |
| 761 | Packages should NOT be released with succeeding TODO tests. As soon |
| 762 | as a TODO test starts working, it should be promoted to a normal test, |
| 763 | and the newly working feature should be documented in the release |
| 764 | notes or in the change log. |
| 765 | |
| 766 | =back |
| 767 | |
| 768 | =head1 ONFAIL |
| 769 | |
| 770 | BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } } |
| 771 | |
| 772 | Although test failures should be enough, extra diagnostics can be |
| 773 | triggered at the end of a test run. C<onfail> is passed an array ref |
| 774 | of hash refs that describe each test failure. Each hash will contain |
| 775 | at least the following fields: C<package>, C<repetition>, and |
| 776 | C<result>. (You shouldn't rely on any other fields being present.) If the test |
| 777 | had an expected value or a diagnostic (or "note") string, these will also be |
| 778 | included. |
| 779 | |
| 780 | The I<optional> C<onfail> hook might be used simply to print out the |
| 781 | version of your package and/or how to report problems. It might also |
| 782 | be used to generate extremely sophisticated diagnostics for a |
| 783 | particularly bizarre test failure. However it's not a panacea. Core |
| 784 | dumps or other unrecoverable errors prevent the C<onfail> hook from |
| 785 | running. (It is run inside an C<END> block.) Besides, C<onfail> is |
| 786 | probably over-kill in most cases. (Your test code should be simpler |
| 787 | than the code it is testing, yes?) |
| 788 | |
| 789 | |
| 790 | =head1 BUGS and CAVEATS |
| 791 | |
| 792 | =over |
| 793 | |
| 794 | =item * |
| 795 | |
| 796 | C<ok(...)>'s special handing of strings which look like they might be |
| 797 | regexes can also cause unexpected behavior. An innocent: |
| 798 | |
| 799 | ok( $fileglob, '/path/to/some/*stuff/' ); |
| 800 | |
| 801 | will fail, since Test.pm considers the second argument to be a regex! |
| 802 | The best bet is to use the one-argument form: |
| 803 | |
| 804 | ok( $fileglob eq '/path/to/some/*stuff/' ); |
| 805 | |
| 806 | =item * |
| 807 | |
| 808 | C<ok(...)>'s use of string C<eq> can sometimes cause odd problems |
| 809 | when comparing |
| 810 | numbers, especially if you're casting a string to a number: |
| 811 | |
| 812 | $foo = "1.0"; |
| 813 | ok( $foo, 1 ); # not ok, "1.0" ne 1 |
| 814 | |
| 815 | Your best bet is to use the single argument form: |
| 816 | |
| 817 | ok( $foo == 1 ); # ok "1.0" == 1 |
| 818 | |
| 819 | =item * |
| 820 | |
| 821 | As you may have inferred from the above documentation and examples, |
| 822 | C<ok>'s prototype is C<($;$$)> (and, incidentally, C<skip>'s is |
| 823 | C<($;$$$)>). This means, for example, that you can do C<ok @foo, @bar> |
| 824 | to compare the I<size> of the two arrays. But don't be fooled into |
| 825 | thinking that C<ok @foo, @bar> means a comparison of the contents of two |
| 826 | arrays -- you're comparing I<just> the number of elements of each. It's |
| 827 | so easy to make that mistake in reading C<ok @foo, @bar> that you might |
| 828 | want to be very explicit about it, and instead write C<ok scalar(@foo), |
| 829 | scalar(@bar)>. |
| 830 | |
| 831 | =item * |
| 832 | |
| 833 | This almost definitely doesn't do what you expect: |
| 834 | |
| 835 | ok $thingy->can('some_method'); |
| 836 | |
| 837 | Why? Because C<can> returns a coderef to mean "yes it can (and the |
| 838 | method is this...)", and then C<ok> sees a coderef and thinks you're |
| 839 | passing a function that you want it to call and consider the truth of |
| 840 | the result of! I.e., just like: |
| 841 | |
| 842 | ok $thingy->can('some_method')->(); |
| 843 | |
| 844 | What you probably want instead is this: |
| 845 | |
| 846 | ok $thingy->can('some_method') && 1; |
| 847 | |
| 848 | If the C<can> returns false, then that is passed to C<ok>. If it |
| 849 | returns true, then the larger expression S<< C<< |
| 850 | $thingy->can('some_method') && 1 >> >> returns 1, which C<ok> sees as |
| 851 | a simple signal of success, as you would expect. |
| 852 | |
| 853 | |
| 854 | =item * |
| 855 | |
| 856 | The syntax for C<skip> is about the only way it can be, but it's still |
| 857 | quite confusing. Just start with the above examples and you'll |
| 858 | be okay. |
| 859 | |
| 860 | Moreover, users may expect this: |
| 861 | |
| 862 | skip $unless_mswin, foo($bar), baz($quux); |
| 863 | |
| 864 | to not evaluate C<foo($bar)> and C<baz($quux)> when the test is being |
| 865 | skipped. But in reality, they I<are> evaluated, but C<skip> just won't |
| 866 | bother comparing them if C<$unless_mswin> is true. |
| 867 | |
| 868 | You could do this: |
| 869 | |
| 870 | skip $unless_mswin, sub{foo($bar)}, sub{baz($quux)}; |
| 871 | |
| 872 | But that's not terribly pretty. You may find it simpler or clearer in |
| 873 | the long run to just do things like this: |
| 874 | |
| 875 | if( $^O =~ m/MSWin/ ) { |
| 876 | print "# Yay, we're under $^O\n"; |
| 877 | ok foo($bar), baz($quux); |
| 878 | ok thing($whatever), baz($stuff); |
| 879 | ok blorp($quux, $whatever); |
| 880 | ok foo($barzbarz), thang($quux); |
| 881 | } else { |
| 882 | print "# Feh, we're under $^O. Watch me skip some tests...\n"; |
| 883 | for(1 .. 4) { skip "Skip unless under MSWin" } |
| 884 | } |
| 885 | |
| 886 | But be quite sure that C<ok> is called exactly as many times in the |
| 887 | first block as C<skip> is called in the second block. |
| 888 | |
| 889 | =back |
| 890 | |
| 891 | |
| 892 | =head1 ENVIRONMENT |
| 893 | |
| 894 | If C<PERL_TEST_DIFF> environment variable is set, it will be used as a |
| 895 | command for comparing unexpected multiline results. If you have GNU |
| 896 | diff installed, you might want to set C<PERL_TEST_DIFF> to C<diff -u>. |
| 897 | If you don't have a suitable program, you might install the |
| 898 | C<Text::Diff> module and then set C<PERL_TEST_DIFF> to be C<perl |
| 899 | -MText::Diff -e 'print diff(@ARGV)'>. If C<PERL_TEST_DIFF> isn't set |
| 900 | but the C<Algorithm::Diff> module is available, then it will be used |
| 901 | to show the differences in multiline results. |
| 902 | |
| 903 | =for comment |
| 904 | If C<PERL_TEST_NO_TRUNC> is set, then the initial "Got 'something' but |
| 905 | expected 'something_else'" readings for long multiline output values aren't |
| 906 | truncated at about the 230th column, as they normally could be in some |
| 907 | cases. Normally you won't need to use this, unless you were carefully |
| 908 | parsing the output of your test programs. |
| 909 | |
| 910 | |
| 911 | =head1 NOTE |
| 912 | |
| 913 | A past developer of this module once said that it was no longer being |
| 914 | actively developed. However, rumors of its demise were greatly |
| 915 | exaggerated. Feedback and suggestions are quite welcome. |
| 916 | |
| 917 | Be aware that the main value of this module is its simplicity. Note |
| 918 | that there are already more ambitious modules out there, such as |
| 919 | L<Test::More> and L<Test::Unit>. |
| 920 | |
| 921 | Some earlier versions of this module had docs with some confusing |
| 922 | typoes in the description of C<skip(...)>. |
| 923 | |
| 924 | |
| 925 | =head1 SEE ALSO |
| 926 | |
| 927 | L<Test::Harness> |
| 928 | |
| 929 | L<Test::Simple>, L<Test::More>, L<Devel::Cover> |
| 930 | |
| 931 | L<Test::Builder> for building your own testing library. |
| 932 | |
| 933 | L<Test::Unit> is an interesting XUnit-style testing library. |
| 934 | |
| 935 | L<Test::Inline> and L<SelfTest> let you embed tests in code. |
| 936 | |
| 937 | |
| 938 | =head1 AUTHOR |
| 939 | |
| 940 | Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved. |
| 941 | |
| 942 | Copyright (c) 2001-2002 Michael G. Schwern. |
| 943 | |
| 944 | Copyright (c) 2002-2004 and counting Sean M. Burke. |
| 945 | |
| 946 | Current maintainer: Sean M. Burke. E<lt>sburke@cpan.orgE<gt> |
| 947 | |
| 948 | This package is free software and is provided "as is" without express |
| 949 | or implied warranty. It may be used, redistributed and/or modified |
| 950 | under the same terms as Perl itself. |
| 951 | |
| 952 | =cut |
| 953 | |
| 954 | # "Your mistake was a hidden intention." |
| 955 | # -- /Oblique Strategies/, Brian Eno and Peter Schmidt |