| 1 | package Test::More; |
| 2 | |
| 3 | use 5.004; |
| 4 | |
| 5 | use strict; |
| 6 | |
| 7 | |
| 8 | # Can't use Carp because it might cause use_ok() to accidentally succeed |
| 9 | # even though the module being used forgot to use Carp. Yes, this |
| 10 | # actually happened. |
| 11 | sub _carp { |
| 12 | my($file, $line) = (caller(1))[1,2]; |
| 13 | warn @_, " at $file line $line\n"; |
| 14 | } |
| 15 | |
| 16 | |
| 17 | |
| 18 | use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); |
| 19 | $VERSION = '0.67'; |
| 20 | $VERSION = eval $VERSION; # make the alpha version come out as a number |
| 21 | |
| 22 | use Test::Builder::Module; |
| 23 | @ISA = qw(Test::Builder::Module); |
| 24 | @EXPORT = qw(ok use_ok require_ok |
| 25 | is isnt like unlike is_deeply |
| 26 | cmp_ok |
| 27 | skip todo todo_skip |
| 28 | pass fail |
| 29 | eq_array eq_hash eq_set |
| 30 | $TODO |
| 31 | plan |
| 32 | can_ok isa_ok |
| 33 | diag |
| 34 | BAIL_OUT |
| 35 | ); |
| 36 | |
| 37 | |
| 38 | =head1 NAME |
| 39 | |
| 40 | Test::More - yet another framework for writing test scripts |
| 41 | |
| 42 | =head1 SYNOPSIS |
| 43 | |
| 44 | use Test::More tests => 23; |
| 45 | # or |
| 46 | use Test::More qw(no_plan); |
| 47 | # or |
| 48 | use Test::More skip_all => $reason; |
| 49 | |
| 50 | BEGIN { use_ok( 'Some::Module' ); } |
| 51 | require_ok( 'Some::Module' ); |
| 52 | |
| 53 | # Various ways to say "ok" |
| 54 | ok($got eq $expected, $test_name); |
| 55 | |
| 56 | is ($got, $exptected, $test_name); |
| 57 | isnt($got, $expected, $test_name); |
| 58 | |
| 59 | # Rather than print STDERR "# here's what went wrong\n" |
| 60 | diag("here's what went wrong"); |
| 61 | |
| 62 | like ($got, qr/expected/, $test_name); |
| 63 | unlike($got, qr/expected/, $test_name); |
| 64 | |
| 65 | cmp_ok($got, '==', $expected, $test_name); |
| 66 | |
| 67 | is_deeply($got_complex_structure, $expected_complex_structure, $test_name); |
| 68 | |
| 69 | SKIP: { |
| 70 | skip $why, $how_many unless $have_some_feature; |
| 71 | |
| 72 | ok( foo(), $test_name ); |
| 73 | is( foo(42), 23, $test_name ); |
| 74 | }; |
| 75 | |
| 76 | TODO: { |
| 77 | local $TODO = $why; |
| 78 | |
| 79 | ok( foo(), $test_name ); |
| 80 | is( foo(42), 23, $test_name ); |
| 81 | }; |
| 82 | |
| 83 | can_ok($module, @methods); |
| 84 | isa_ok($object, $class); |
| 85 | |
| 86 | pass($test_name); |
| 87 | fail($test_name); |
| 88 | |
| 89 | BAIL_OUT($why); |
| 90 | |
| 91 | # UNIMPLEMENTED!!! |
| 92 | my @status = Test::More::status; |
| 93 | |
| 94 | |
| 95 | =head1 DESCRIPTION |
| 96 | |
| 97 | B<STOP!> If you're just getting started writing tests, have a look at |
| 98 | Test::Simple first. This is a drop in replacement for Test::Simple |
| 99 | which you can switch to once you get the hang of basic testing. |
| 100 | |
| 101 | The purpose of this module is to provide a wide range of testing |
| 102 | utilities. Various ways to say "ok" with better diagnostics, |
| 103 | facilities to skip tests, test future features and compare complicated |
| 104 | data structures. While you can do almost anything with a simple |
| 105 | C<ok()> function, it doesn't provide good diagnostic output. |
| 106 | |
| 107 | |
| 108 | =head2 I love it when a plan comes together |
| 109 | |
| 110 | Before anything else, you need a testing plan. This basically declares |
| 111 | how many tests your script is going to run to protect against premature |
| 112 | failure. |
| 113 | |
| 114 | The preferred way to do this is to declare a plan when you C<use Test::More>. |
| 115 | |
| 116 | use Test::More tests => 23; |
| 117 | |
| 118 | There are rare cases when you will not know beforehand how many tests |
| 119 | your script is going to run. In this case, you can declare that you |
| 120 | have no plan. (Try to avoid using this as it weakens your test.) |
| 121 | |
| 122 | use Test::More qw(no_plan); |
| 123 | |
| 124 | B<NOTE>: using no_plan requires a Test::Harness upgrade else it will |
| 125 | think everything has failed. See L<CAVEATS and NOTES>). |
| 126 | |
| 127 | In some cases, you'll want to completely skip an entire testing script. |
| 128 | |
| 129 | use Test::More skip_all => $skip_reason; |
| 130 | |
| 131 | Your script will declare a skip with the reason why you skipped and |
| 132 | exit immediately with a zero (success). See L<Test::Harness> for |
| 133 | details. |
| 134 | |
| 135 | If you want to control what functions Test::More will export, you |
| 136 | have to use the 'import' option. For example, to import everything |
| 137 | but 'fail', you'd do: |
| 138 | |
| 139 | use Test::More tests => 23, import => ['!fail']; |
| 140 | |
| 141 | Alternatively, you can use the plan() function. Useful for when you |
| 142 | have to calculate the number of tests. |
| 143 | |
| 144 | use Test::More; |
| 145 | plan tests => keys %Stuff * 3; |
| 146 | |
| 147 | or for deciding between running the tests at all: |
| 148 | |
| 149 | use Test::More; |
| 150 | if( $^O eq 'MacOS' ) { |
| 151 | plan skip_all => 'Test irrelevant on MacOS'; |
| 152 | } |
| 153 | else { |
| 154 | plan tests => 42; |
| 155 | } |
| 156 | |
| 157 | =cut |
| 158 | |
| 159 | sub plan { |
| 160 | my $tb = Test::More->builder; |
| 161 | |
| 162 | $tb->plan(@_); |
| 163 | } |
| 164 | |
| 165 | |
| 166 | # This implements "use Test::More 'no_diag'" but the behavior is |
| 167 | # deprecated. |
| 168 | sub import_extra { |
| 169 | my $class = shift; |
| 170 | my $list = shift; |
| 171 | |
| 172 | my @other = (); |
| 173 | my $idx = 0; |
| 174 | while( $idx <= $#{$list} ) { |
| 175 | my $item = $list->[$idx]; |
| 176 | |
| 177 | if( defined $item and $item eq 'no_diag' ) { |
| 178 | $class->builder->no_diag(1); |
| 179 | } |
| 180 | else { |
| 181 | push @other, $item; |
| 182 | } |
| 183 | |
| 184 | $idx++; |
| 185 | } |
| 186 | |
| 187 | @$list = @other; |
| 188 | } |
| 189 | |
| 190 | |
| 191 | =head2 Test names |
| 192 | |
| 193 | By convention, each test is assigned a number in order. This is |
| 194 | largely done automatically for you. However, it's often very useful to |
| 195 | assign a name to each test. Which would you rather see: |
| 196 | |
| 197 | ok 4 |
| 198 | not ok 5 |
| 199 | ok 6 |
| 200 | |
| 201 | or |
| 202 | |
| 203 | ok 4 - basic multi-variable |
| 204 | not ok 5 - simple exponential |
| 205 | ok 6 - force == mass * acceleration |
| 206 | |
| 207 | The later gives you some idea of what failed. It also makes it easier |
| 208 | to find the test in your script, simply search for "simple |
| 209 | exponential". |
| 210 | |
| 211 | All test functions take a name argument. It's optional, but highly |
| 212 | suggested that you use it. |
| 213 | |
| 214 | |
| 215 | =head2 I'm ok, you're not ok. |
| 216 | |
| 217 | The basic purpose of this module is to print out either "ok #" or "not |
| 218 | ok #" depending on if a given test succeeded or failed. Everything |
| 219 | else is just gravy. |
| 220 | |
| 221 | All of the following print "ok" or "not ok" depending on if the test |
| 222 | succeeded or failed. They all also return true or false, |
| 223 | respectively. |
| 224 | |
| 225 | =over 4 |
| 226 | |
| 227 | =item B<ok> |
| 228 | |
| 229 | ok($got eq $expected, $test_name); |
| 230 | |
| 231 | This simply evaluates any expression (C<$got eq $expected> is just a |
| 232 | simple example) and uses that to determine if the test succeeded or |
| 233 | failed. A true expression passes, a false one fails. Very simple. |
| 234 | |
| 235 | For example: |
| 236 | |
| 237 | ok( $exp{9} == 81, 'simple exponential' ); |
| 238 | ok( Film->can('db_Main'), 'set_db()' ); |
| 239 | ok( $p->tests == 4, 'saw tests' ); |
| 240 | ok( !grep !defined $_, @items, 'items populated' ); |
| 241 | |
| 242 | (Mnemonic: "This is ok.") |
| 243 | |
| 244 | $test_name is a very short description of the test that will be printed |
| 245 | out. It makes it very easy to find a test in your script when it fails |
| 246 | and gives others an idea of your intentions. $test_name is optional, |
| 247 | but we B<very> strongly encourage its use. |
| 248 | |
| 249 | Should an ok() fail, it will produce some diagnostics: |
| 250 | |
| 251 | not ok 18 - sufficient mucus |
| 252 | # Failed test 'sufficient mucus' |
| 253 | # in foo.t at line 42. |
| 254 | |
| 255 | This is the same as Test::Simple's ok() routine. |
| 256 | |
| 257 | =cut |
| 258 | |
| 259 | sub ok ($;$) { |
| 260 | my($test, $name) = @_; |
| 261 | my $tb = Test::More->builder; |
| 262 | |
| 263 | $tb->ok($test, $name); |
| 264 | } |
| 265 | |
| 266 | =item B<is> |
| 267 | |
| 268 | =item B<isnt> |
| 269 | |
| 270 | is ( $got, $expected, $test_name ); |
| 271 | isnt( $got, $expected, $test_name ); |
| 272 | |
| 273 | Similar to ok(), is() and isnt() compare their two arguments |
| 274 | with C<eq> and C<ne> respectively and use the result of that to |
| 275 | determine if the test succeeded or failed. So these: |
| 276 | |
| 277 | # Is the ultimate answer 42? |
| 278 | is( ultimate_answer(), 42, "Meaning of Life" ); |
| 279 | |
| 280 | # $foo isn't empty |
| 281 | isnt( $foo, '', "Got some foo" ); |
| 282 | |
| 283 | are similar to these: |
| 284 | |
| 285 | ok( ultimate_answer() eq 42, "Meaning of Life" ); |
| 286 | ok( $foo ne '', "Got some foo" ); |
| 287 | |
| 288 | (Mnemonic: "This is that." "This isn't that.") |
| 289 | |
| 290 | So why use these? They produce better diagnostics on failure. ok() |
| 291 | cannot know what you are testing for (beyond the name), but is() and |
| 292 | isnt() know what the test was and why it failed. For example this |
| 293 | test: |
| 294 | |
| 295 | my $foo = 'waffle'; my $bar = 'yarblokos'; |
| 296 | is( $foo, $bar, 'Is foo the same as bar?' ); |
| 297 | |
| 298 | Will produce something like this: |
| 299 | |
| 300 | not ok 17 - Is foo the same as bar? |
| 301 | # Failed test 'Is foo the same as bar?' |
| 302 | # in foo.t at line 139. |
| 303 | # got: 'waffle' |
| 304 | # expected: 'yarblokos' |
| 305 | |
| 306 | So you can figure out what went wrong without rerunning the test. |
| 307 | |
| 308 | You are encouraged to use is() and isnt() over ok() where possible, |
| 309 | however do not be tempted to use them to find out if something is |
| 310 | true or false! |
| 311 | |
| 312 | # XXX BAD! |
| 313 | is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' ); |
| 314 | |
| 315 | This does not check if C<exists $brooklyn{tree}> is true, it checks if |
| 316 | it returns 1. Very different. Similar caveats exist for false and 0. |
| 317 | In these cases, use ok(). |
| 318 | |
| 319 | ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' ); |
| 320 | |
| 321 | For those grammatical pedants out there, there's an C<isn't()> |
| 322 | function which is an alias of isnt(). |
| 323 | |
| 324 | =cut |
| 325 | |
| 326 | sub is ($$;$) { |
| 327 | my $tb = Test::More->builder; |
| 328 | |
| 329 | $tb->is_eq(@_); |
| 330 | } |
| 331 | |
| 332 | sub isnt ($$;$) { |
| 333 | my $tb = Test::More->builder; |
| 334 | |
| 335 | $tb->isnt_eq(@_); |
| 336 | } |
| 337 | |
| 338 | *isn't = \&isnt; |
| 339 | |
| 340 | |
| 341 | =item B<like> |
| 342 | |
| 343 | like( $got, qr/expected/, $test_name ); |
| 344 | |
| 345 | Similar to ok(), like() matches $got against the regex C<qr/expected/>. |
| 346 | |
| 347 | So this: |
| 348 | |
| 349 | like($got, qr/expected/, 'this is like that'); |
| 350 | |
| 351 | is similar to: |
| 352 | |
| 353 | ok( $got =~ /expected/, 'this is like that'); |
| 354 | |
| 355 | (Mnemonic "This is like that".) |
| 356 | |
| 357 | The second argument is a regular expression. It may be given as a |
| 358 | regex reference (i.e. C<qr//>) or (for better compatibility with older |
| 359 | perls) as a string that looks like a regex (alternative delimiters are |
| 360 | currently not supported): |
| 361 | |
| 362 | like( $got, '/expected/', 'this is like that' ); |
| 363 | |
| 364 | Regex options may be placed on the end (C<'/expected/i'>). |
| 365 | |
| 366 | Its advantages over ok() are similar to that of is() and isnt(). Better |
| 367 | diagnostics on failure. |
| 368 | |
| 369 | =cut |
| 370 | |
| 371 | sub like ($$;$) { |
| 372 | my $tb = Test::More->builder; |
| 373 | |
| 374 | $tb->like(@_); |
| 375 | } |
| 376 | |
| 377 | |
| 378 | =item B<unlike> |
| 379 | |
| 380 | unlike( $got, qr/expected/, $test_name ); |
| 381 | |
| 382 | Works exactly as like(), only it checks if $got B<does not> match the |
| 383 | given pattern. |
| 384 | |
| 385 | =cut |
| 386 | |
| 387 | sub unlike ($$;$) { |
| 388 | my $tb = Test::More->builder; |
| 389 | |
| 390 | $tb->unlike(@_); |
| 391 | } |
| 392 | |
| 393 | |
| 394 | =item B<cmp_ok> |
| 395 | |
| 396 | cmp_ok( $got, $op, $expected, $test_name ); |
| 397 | |
| 398 | Halfway between ok() and is() lies cmp_ok(). This allows you to |
| 399 | compare two arguments using any binary perl operator. |
| 400 | |
| 401 | # ok( $got eq $expected ); |
| 402 | cmp_ok( $got, 'eq', $expected, 'this eq that' ); |
| 403 | |
| 404 | # ok( $got == $expected ); |
| 405 | cmp_ok( $got, '==', $expected, 'this == that' ); |
| 406 | |
| 407 | # ok( $got && $expected ); |
| 408 | cmp_ok( $got, '&&', $expected, 'this && that' ); |
| 409 | ...etc... |
| 410 | |
| 411 | Its advantage over ok() is when the test fails you'll know what $got |
| 412 | and $expected were: |
| 413 | |
| 414 | not ok 1 |
| 415 | # Failed test in foo.t at line 12. |
| 416 | # '23' |
| 417 | # && |
| 418 | # undef |
| 419 | |
| 420 | It's also useful in those cases where you are comparing numbers and |
| 421 | is()'s use of C<eq> will interfere: |
| 422 | |
| 423 | cmp_ok( $big_hairy_number, '==', $another_big_hairy_number ); |
| 424 | |
| 425 | =cut |
| 426 | |
| 427 | sub cmp_ok($$$;$) { |
| 428 | my $tb = Test::More->builder; |
| 429 | |
| 430 | $tb->cmp_ok(@_); |
| 431 | } |
| 432 | |
| 433 | |
| 434 | =item B<can_ok> |
| 435 | |
| 436 | can_ok($module, @methods); |
| 437 | can_ok($object, @methods); |
| 438 | |
| 439 | Checks to make sure the $module or $object can do these @methods |
| 440 | (works with functions, too). |
| 441 | |
| 442 | can_ok('Foo', qw(this that whatever)); |
| 443 | |
| 444 | is almost exactly like saying: |
| 445 | |
| 446 | ok( Foo->can('this') && |
| 447 | Foo->can('that') && |
| 448 | Foo->can('whatever') |
| 449 | ); |
| 450 | |
| 451 | only without all the typing and with a better interface. Handy for |
| 452 | quickly testing an interface. |
| 453 | |
| 454 | No matter how many @methods you check, a single can_ok() call counts |
| 455 | as one test. If you desire otherwise, use: |
| 456 | |
| 457 | foreach my $meth (@methods) { |
| 458 | can_ok('Foo', $meth); |
| 459 | } |
| 460 | |
| 461 | =cut |
| 462 | |
| 463 | sub can_ok ($@) { |
| 464 | my($proto, @methods) = @_; |
| 465 | my $class = ref $proto || $proto; |
| 466 | my $tb = Test::More->builder; |
| 467 | |
| 468 | unless( $class ) { |
| 469 | my $ok = $tb->ok( 0, "->can(...)" ); |
| 470 | $tb->diag(' can_ok() called with empty class or reference'); |
| 471 | return $ok; |
| 472 | } |
| 473 | |
| 474 | unless( @methods ) { |
| 475 | my $ok = $tb->ok( 0, "$class->can(...)" ); |
| 476 | $tb->diag(' can_ok() called with no methods'); |
| 477 | return $ok; |
| 478 | } |
| 479 | |
| 480 | my @nok = (); |
| 481 | foreach my $method (@methods) { |
| 482 | local($!, $@); # don't interfere with caller's $@ |
| 483 | # eval sometimes resets $! |
| 484 | eval { $proto->can($method) } || push @nok, $method; |
| 485 | } |
| 486 | |
| 487 | my $name; |
| 488 | $name = @methods == 1 ? "$class->can('$methods[0]')" |
| 489 | : "$class->can(...)"; |
| 490 | |
| 491 | my $ok = $tb->ok( !@nok, $name ); |
| 492 | |
| 493 | $tb->diag(map " $class->can('$_') failed\n", @nok); |
| 494 | |
| 495 | return $ok; |
| 496 | } |
| 497 | |
| 498 | =item B<isa_ok> |
| 499 | |
| 500 | isa_ok($object, $class, $object_name); |
| 501 | isa_ok($ref, $type, $ref_name); |
| 502 | |
| 503 | Checks to see if the given C<< $object->isa($class) >>. Also checks to make |
| 504 | sure the object was defined in the first place. Handy for this sort |
| 505 | of thing: |
| 506 | |
| 507 | my $obj = Some::Module->new; |
| 508 | isa_ok( $obj, 'Some::Module' ); |
| 509 | |
| 510 | where you'd otherwise have to write |
| 511 | |
| 512 | my $obj = Some::Module->new; |
| 513 | ok( defined $obj && $obj->isa('Some::Module') ); |
| 514 | |
| 515 | to safeguard against your test script blowing up. |
| 516 | |
| 517 | It works on references, too: |
| 518 | |
| 519 | isa_ok( $array_ref, 'ARRAY' ); |
| 520 | |
| 521 | The diagnostics of this test normally just refer to 'the object'. If |
| 522 | you'd like them to be more specific, you can supply an $object_name |
| 523 | (for example 'Test customer'). |
| 524 | |
| 525 | =cut |
| 526 | |
| 527 | sub isa_ok ($$;$) { |
| 528 | my($object, $class, $obj_name) = @_; |
| 529 | my $tb = Test::More->builder; |
| 530 | |
| 531 | my $diag; |
| 532 | $obj_name = 'The object' unless defined $obj_name; |
| 533 | my $name = "$obj_name isa $class"; |
| 534 | if( !defined $object ) { |
| 535 | $diag = "$obj_name isn't defined"; |
| 536 | } |
| 537 | elsif( !ref $object ) { |
| 538 | $diag = "$obj_name isn't a reference"; |
| 539 | } |
| 540 | else { |
| 541 | # We can't use UNIVERSAL::isa because we want to honor isa() overrides |
| 542 | local($@, $!); # eval sometimes resets $! |
| 543 | my $rslt = eval { $object->isa($class) }; |
| 544 | if( $@ ) { |
| 545 | if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { |
| 546 | if( !UNIVERSAL::isa($object, $class) ) { |
| 547 | my $ref = ref $object; |
| 548 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; |
| 549 | } |
| 550 | } else { |
| 551 | die <<WHOA; |
| 552 | WHOA! I tried to call ->isa on your object and got some weird error. |
| 553 | This should never happen. Please contact the author immediately. |
| 554 | Here's the error. |
| 555 | $@ |
| 556 | WHOA |
| 557 | } |
| 558 | } |
| 559 | elsif( !$rslt ) { |
| 560 | my $ref = ref $object; |
| 561 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; |
| 562 | } |
| 563 | } |
| 564 | |
| 565 | |
| 566 | |
| 567 | my $ok; |
| 568 | if( $diag ) { |
| 569 | $ok = $tb->ok( 0, $name ); |
| 570 | $tb->diag(" $diag\n"); |
| 571 | } |
| 572 | else { |
| 573 | $ok = $tb->ok( 1, $name ); |
| 574 | } |
| 575 | |
| 576 | return $ok; |
| 577 | } |
| 578 | |
| 579 | |
| 580 | =item B<pass> |
| 581 | |
| 582 | =item B<fail> |
| 583 | |
| 584 | pass($test_name); |
| 585 | fail($test_name); |
| 586 | |
| 587 | Sometimes you just want to say that the tests have passed. Usually |
| 588 | the case is you've got some complicated condition that is difficult to |
| 589 | wedge into an ok(). In this case, you can simply use pass() (to |
| 590 | declare the test ok) or fail (for not ok). They are synonyms for |
| 591 | ok(1) and ok(0). |
| 592 | |
| 593 | Use these very, very, very sparingly. |
| 594 | |
| 595 | =cut |
| 596 | |
| 597 | sub pass (;$) { |
| 598 | my $tb = Test::More->builder; |
| 599 | $tb->ok(1, @_); |
| 600 | } |
| 601 | |
| 602 | sub fail (;$) { |
| 603 | my $tb = Test::More->builder; |
| 604 | $tb->ok(0, @_); |
| 605 | } |
| 606 | |
| 607 | =back |
| 608 | |
| 609 | |
| 610 | =head2 Module tests |
| 611 | |
| 612 | You usually want to test if the module you're testing loads ok, rather |
| 613 | than just vomiting if its load fails. For such purposes we have |
| 614 | C<use_ok> and C<require_ok>. |
| 615 | |
| 616 | =over 4 |
| 617 | |
| 618 | =item B<use_ok> |
| 619 | |
| 620 | BEGIN { use_ok($module); } |
| 621 | BEGIN { use_ok($module, @imports); } |
| 622 | |
| 623 | These simply use the given $module and test to make sure the load |
| 624 | happened ok. It's recommended that you run use_ok() inside a BEGIN |
| 625 | block so its functions are exported at compile-time and prototypes are |
| 626 | properly honored. |
| 627 | |
| 628 | If @imports are given, they are passed through to the use. So this: |
| 629 | |
| 630 | BEGIN { use_ok('Some::Module', qw(foo bar)) } |
| 631 | |
| 632 | is like doing this: |
| 633 | |
| 634 | use Some::Module qw(foo bar); |
| 635 | |
| 636 | Version numbers can be checked like so: |
| 637 | |
| 638 | # Just like "use Some::Module 1.02" |
| 639 | BEGIN { use_ok('Some::Module', 1.02) } |
| 640 | |
| 641 | Don't try to do this: |
| 642 | |
| 643 | BEGIN { |
| 644 | use_ok('Some::Module'); |
| 645 | |
| 646 | ...some code that depends on the use... |
| 647 | ...happening at compile time... |
| 648 | } |
| 649 | |
| 650 | because the notion of "compile-time" is relative. Instead, you want: |
| 651 | |
| 652 | BEGIN { use_ok('Some::Module') } |
| 653 | BEGIN { ...some code that depends on the use... } |
| 654 | |
| 655 | |
| 656 | =cut |
| 657 | |
| 658 | sub use_ok ($;@) { |
| 659 | my($module, @imports) = @_; |
| 660 | @imports = () unless @imports; |
| 661 | my $tb = Test::More->builder; |
| 662 | |
| 663 | my($pack,$filename,$line) = caller; |
| 664 | |
| 665 | local($@,$!); # eval sometimes interferes with $! |
| 666 | |
| 667 | if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { |
| 668 | # probably a version check. Perl needs to see the bare number |
| 669 | # for it to work with non-Exporter based modules. |
| 670 | eval <<USE; |
| 671 | package $pack; |
| 672 | use $module $imports[0]; |
| 673 | USE |
| 674 | } |
| 675 | else { |
| 676 | eval <<USE; |
| 677 | package $pack; |
| 678 | use $module \@imports; |
| 679 | USE |
| 680 | } |
| 681 | |
| 682 | my $ok = $tb->ok( !$@, "use $module;" ); |
| 683 | |
| 684 | unless( $ok ) { |
| 685 | chomp $@; |
| 686 | $@ =~ s{^BEGIN failed--compilation aborted at .*$} |
| 687 | {BEGIN failed--compilation aborted at $filename line $line.}m; |
| 688 | $tb->diag(<<DIAGNOSTIC); |
| 689 | Tried to use '$module'. |
| 690 | Error: $@ |
| 691 | DIAGNOSTIC |
| 692 | |
| 693 | } |
| 694 | |
| 695 | return $ok; |
| 696 | } |
| 697 | |
| 698 | =item B<require_ok> |
| 699 | |
| 700 | require_ok($module); |
| 701 | require_ok($file); |
| 702 | |
| 703 | Like use_ok(), except it requires the $module or $file. |
| 704 | |
| 705 | =cut |
| 706 | |
| 707 | sub require_ok ($) { |
| 708 | my($module) = shift; |
| 709 | my $tb = Test::More->builder; |
| 710 | |
| 711 | my $pack = caller; |
| 712 | |
| 713 | # Try to deterine if we've been given a module name or file. |
| 714 | # Module names must be barewords, files not. |
| 715 | $module = qq['$module'] unless _is_module_name($module); |
| 716 | |
| 717 | local($!, $@); # eval sometimes interferes with $! |
| 718 | eval <<REQUIRE; |
| 719 | package $pack; |
| 720 | require $module; |
| 721 | REQUIRE |
| 722 | |
| 723 | my $ok = $tb->ok( !$@, "require $module;" ); |
| 724 | |
| 725 | unless( $ok ) { |
| 726 | chomp $@; |
| 727 | $tb->diag(<<DIAGNOSTIC); |
| 728 | Tried to require '$module'. |
| 729 | Error: $@ |
| 730 | DIAGNOSTIC |
| 731 | |
| 732 | } |
| 733 | |
| 734 | return $ok; |
| 735 | } |
| 736 | |
| 737 | |
| 738 | sub _is_module_name { |
| 739 | my $module = shift; |
| 740 | |
| 741 | # Module names start with a letter. |
| 742 | # End with an alphanumeric. |
| 743 | # The rest is an alphanumeric or :: |
| 744 | $module =~ s/\b::\b//g; |
| 745 | $module =~ /^[a-zA-Z]\w*$/; |
| 746 | } |
| 747 | |
| 748 | =back |
| 749 | |
| 750 | |
| 751 | =head2 Complex data structures |
| 752 | |
| 753 | Not everything is a simple eq check or regex. There are times you |
| 754 | need to see if two data structures are equivalent. For these |
| 755 | instances Test::More provides a handful of useful functions. |
| 756 | |
| 757 | B<NOTE> I'm not quite sure what will happen with filehandles. |
| 758 | |
| 759 | =over 4 |
| 760 | |
| 761 | =item B<is_deeply> |
| 762 | |
| 763 | is_deeply( $got, $expected, $test_name ); |
| 764 | |
| 765 | Similar to is(), except that if $got and $expected are references, it |
| 766 | does a deep comparison walking each data structure to see if they are |
| 767 | equivalent. If the two structures are different, it will display the |
| 768 | place where they start differing. |
| 769 | |
| 770 | is_deeply() compares the dereferenced values of references, the |
| 771 | references themselves (except for their type) are ignored. This means |
| 772 | aspects such as blessing and ties are not considered "different". |
| 773 | |
| 774 | is_deeply() current has very limited handling of function reference |
| 775 | and globs. It merely checks if they have the same referent. This may |
| 776 | improve in the future. |
| 777 | |
| 778 | Test::Differences and Test::Deep provide more in-depth functionality |
| 779 | along these lines. |
| 780 | |
| 781 | =cut |
| 782 | |
| 783 | use vars qw(@Data_Stack %Refs_Seen); |
| 784 | my $DNE = bless [], 'Does::Not::Exist'; |
| 785 | sub is_deeply { |
| 786 | my $tb = Test::More->builder; |
| 787 | |
| 788 | unless( @_ == 2 or @_ == 3 ) { |
| 789 | my $msg = <<WARNING; |
| 790 | is_deeply() takes two or three args, you gave %d. |
| 791 | This usually means you passed an array or hash instead |
| 792 | of a reference to it |
| 793 | WARNING |
| 794 | chop $msg; # clip off newline so carp() will put in line/file |
| 795 | |
| 796 | _carp sprintf $msg, scalar @_; |
| 797 | |
| 798 | return $tb->ok(0); |
| 799 | } |
| 800 | |
| 801 | my($got, $expected, $name) = @_; |
| 802 | |
| 803 | $tb->_unoverload_str(\$expected, \$got); |
| 804 | |
| 805 | my $ok; |
| 806 | if( !ref $got and !ref $expected ) { # neither is a reference |
| 807 | $ok = $tb->is_eq($got, $expected, $name); |
| 808 | } |
| 809 | elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't |
| 810 | $ok = $tb->ok(0, $name); |
| 811 | $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); |
| 812 | } |
| 813 | else { # both references |
| 814 | local @Data_Stack = (); |
| 815 | if( _deep_check($got, $expected) ) { |
| 816 | $ok = $tb->ok(1, $name); |
| 817 | } |
| 818 | else { |
| 819 | $ok = $tb->ok(0, $name); |
| 820 | $tb->diag(_format_stack(@Data_Stack)); |
| 821 | } |
| 822 | } |
| 823 | |
| 824 | return $ok; |
| 825 | } |
| 826 | |
| 827 | sub _format_stack { |
| 828 | my(@Stack) = @_; |
| 829 | |
| 830 | my $var = '$FOO'; |
| 831 | my $did_arrow = 0; |
| 832 | foreach my $entry (@Stack) { |
| 833 | my $type = $entry->{type} || ''; |
| 834 | my $idx = $entry->{'idx'}; |
| 835 | if( $type eq 'HASH' ) { |
| 836 | $var .= "->" unless $did_arrow++; |
| 837 | $var .= "{$idx}"; |
| 838 | } |
| 839 | elsif( $type eq 'ARRAY' ) { |
| 840 | $var .= "->" unless $did_arrow++; |
| 841 | $var .= "[$idx]"; |
| 842 | } |
| 843 | elsif( $type eq 'REF' ) { |
| 844 | $var = "\${$var}"; |
| 845 | } |
| 846 | } |
| 847 | |
| 848 | my @vals = @{$Stack[-1]{vals}}[0,1]; |
| 849 | my @vars = (); |
| 850 | ($vars[0] = $var) =~ s/\$FOO/ \$got/; |
| 851 | ($vars[1] = $var) =~ s/\$FOO/\$expected/; |
| 852 | |
| 853 | my $out = "Structures begin differing at:\n"; |
| 854 | foreach my $idx (0..$#vals) { |
| 855 | my $val = $vals[$idx]; |
| 856 | $vals[$idx] = !defined $val ? 'undef' : |
| 857 | $val eq $DNE ? "Does not exist" : |
| 858 | ref $val ? "$val" : |
| 859 | "'$val'"; |
| 860 | } |
| 861 | |
| 862 | $out .= "$vars[0] = $vals[0]\n"; |
| 863 | $out .= "$vars[1] = $vals[1]\n"; |
| 864 | |
| 865 | $out =~ s/^/ /msg; |
| 866 | return $out; |
| 867 | } |
| 868 | |
| 869 | |
| 870 | sub _type { |
| 871 | my $thing = shift; |
| 872 | |
| 873 | return '' if !ref $thing; |
| 874 | |
| 875 | for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { |
| 876 | return $type if UNIVERSAL::isa($thing, $type); |
| 877 | } |
| 878 | |
| 879 | return ''; |
| 880 | } |
| 881 | |
| 882 | =back |
| 883 | |
| 884 | |
| 885 | =head2 Diagnostics |
| 886 | |
| 887 | If you pick the right test function, you'll usually get a good idea of |
| 888 | what went wrong when it failed. But sometimes it doesn't work out |
| 889 | that way. So here we have ways for you to write your own diagnostic |
| 890 | messages which are safer than just C<print STDERR>. |
| 891 | |
| 892 | =over 4 |
| 893 | |
| 894 | =item B<diag> |
| 895 | |
| 896 | diag(@diagnostic_message); |
| 897 | |
| 898 | Prints a diagnostic message which is guaranteed not to interfere with |
| 899 | test output. Like C<print> @diagnostic_message is simply concatenated |
| 900 | together. |
| 901 | |
| 902 | Handy for this sort of thing: |
| 903 | |
| 904 | ok( grep(/foo/, @users), "There's a foo user" ) or |
| 905 | diag("Since there's no foo, check that /etc/bar is set up right"); |
| 906 | |
| 907 | which would produce: |
| 908 | |
| 909 | not ok 42 - There's a foo user |
| 910 | # Failed test 'There's a foo user' |
| 911 | # in foo.t at line 52. |
| 912 | # Since there's no foo, check that /etc/bar is set up right. |
| 913 | |
| 914 | You might remember C<ok() or diag()> with the mnemonic C<open() or |
| 915 | die()>. |
| 916 | |
| 917 | B<NOTE> The exact formatting of the diagnostic output is still |
| 918 | changing, but it is guaranteed that whatever you throw at it it won't |
| 919 | interfere with the test. |
| 920 | |
| 921 | =cut |
| 922 | |
| 923 | sub diag { |
| 924 | my $tb = Test::More->builder; |
| 925 | |
| 926 | $tb->diag(@_); |
| 927 | } |
| 928 | |
| 929 | |
| 930 | =back |
| 931 | |
| 932 | |
| 933 | =head2 Conditional tests |
| 934 | |
| 935 | Sometimes running a test under certain conditions will cause the |
| 936 | test script to die. A certain function or method isn't implemented |
| 937 | (such as fork() on MacOS), some resource isn't available (like a |
| 938 | net connection) or a module isn't available. In these cases it's |
| 939 | necessary to skip tests, or declare that they are supposed to fail |
| 940 | but will work in the future (a todo test). |
| 941 | |
| 942 | For more details on the mechanics of skip and todo tests see |
| 943 | L<Test::Harness>. |
| 944 | |
| 945 | The way Test::More handles this is with a named block. Basically, a |
| 946 | block of tests which can be skipped over or made todo. It's best if I |
| 947 | just show you... |
| 948 | |
| 949 | =over 4 |
| 950 | |
| 951 | =item B<SKIP: BLOCK> |
| 952 | |
| 953 | SKIP: { |
| 954 | skip $why, $how_many if $condition; |
| 955 | |
| 956 | ...normal testing code goes here... |
| 957 | } |
| 958 | |
| 959 | This declares a block of tests that might be skipped, $how_many tests |
| 960 | there are, $why and under what $condition to skip them. An example is |
| 961 | the easiest way to illustrate: |
| 962 | |
| 963 | SKIP: { |
| 964 | eval { require HTML::Lint }; |
| 965 | |
| 966 | skip "HTML::Lint not installed", 2 if $@; |
| 967 | |
| 968 | my $lint = new HTML::Lint; |
| 969 | isa_ok( $lint, "HTML::Lint" ); |
| 970 | |
| 971 | $lint->parse( $html ); |
| 972 | is( $lint->errors, 0, "No errors found in HTML" ); |
| 973 | } |
| 974 | |
| 975 | If the user does not have HTML::Lint installed, the whole block of |
| 976 | code I<won't be run at all>. Test::More will output special ok's |
| 977 | which Test::Harness interprets as skipped, but passing, tests. |
| 978 | |
| 979 | It's important that $how_many accurately reflects the number of tests |
| 980 | in the SKIP block so the # of tests run will match up with your plan. |
| 981 | If your plan is C<no_plan> $how_many is optional and will default to 1. |
| 982 | |
| 983 | It's perfectly safe to nest SKIP blocks. Each SKIP block must have |
| 984 | the label C<SKIP>, or Test::More can't work its magic. |
| 985 | |
| 986 | You don't skip tests which are failing because there's a bug in your |
| 987 | program, or for which you don't yet have code written. For that you |
| 988 | use TODO. Read on. |
| 989 | |
| 990 | =cut |
| 991 | |
| 992 | #'# |
| 993 | sub skip { |
| 994 | my($why, $how_many) = @_; |
| 995 | my $tb = Test::More->builder; |
| 996 | |
| 997 | unless( defined $how_many ) { |
| 998 | # $how_many can only be avoided when no_plan is in use. |
| 999 | _carp "skip() needs to know \$how_many tests are in the block" |
| 1000 | unless $tb->has_plan eq 'no_plan'; |
| 1001 | $how_many = 1; |
| 1002 | } |
| 1003 | |
| 1004 | if( defined $how_many and $how_many =~ /\D/ ) { |
| 1005 | _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; |
| 1006 | $how_many = 1; |
| 1007 | } |
| 1008 | |
| 1009 | for( 1..$how_many ) { |
| 1010 | $tb->skip($why); |
| 1011 | } |
| 1012 | |
| 1013 | local $^W = 0; |
| 1014 | last SKIP; |
| 1015 | } |
| 1016 | |
| 1017 | |
| 1018 | =item B<TODO: BLOCK> |
| 1019 | |
| 1020 | TODO: { |
| 1021 | local $TODO = $why if $condition; |
| 1022 | |
| 1023 | ...normal testing code goes here... |
| 1024 | } |
| 1025 | |
| 1026 | Declares a block of tests you expect to fail and $why. Perhaps it's |
| 1027 | because you haven't fixed a bug or haven't finished a new feature: |
| 1028 | |
| 1029 | TODO: { |
| 1030 | local $TODO = "URI::Geller not finished"; |
| 1031 | |
| 1032 | my $card = "Eight of clubs"; |
| 1033 | is( URI::Geller->your_card, $card, 'Is THIS your card?' ); |
| 1034 | |
| 1035 | my $spoon; |
| 1036 | URI::Geller->bend_spoon; |
| 1037 | is( $spoon, 'bent', "Spoon bending, that's original" ); |
| 1038 | } |
| 1039 | |
| 1040 | With a todo block, the tests inside are expected to fail. Test::More |
| 1041 | will run the tests normally, but print out special flags indicating |
| 1042 | they are "todo". Test::Harness will interpret failures as being ok. |
| 1043 | Should anything succeed, it will report it as an unexpected success. |
| 1044 | You then know the thing you had todo is done and can remove the |
| 1045 | TODO flag. |
| 1046 | |
| 1047 | The nice part about todo tests, as opposed to simply commenting out a |
| 1048 | block of tests, is it's like having a programmatic todo list. You know |
| 1049 | how much work is left to be done, you're aware of what bugs there are, |
| 1050 | and you'll know immediately when they're fixed. |
| 1051 | |
| 1052 | Once a todo test starts succeeding, simply move it outside the block. |
| 1053 | When the block is empty, delete it. |
| 1054 | |
| 1055 | B<NOTE>: TODO tests require a Test::Harness upgrade else it will |
| 1056 | treat it as a normal failure. See L<CAVEATS and NOTES>). |
| 1057 | |
| 1058 | |
| 1059 | =item B<todo_skip> |
| 1060 | |
| 1061 | TODO: { |
| 1062 | todo_skip $why, $how_many if $condition; |
| 1063 | |
| 1064 | ...normal testing code... |
| 1065 | } |
| 1066 | |
| 1067 | With todo tests, it's best to have the tests actually run. That way |
| 1068 | you'll know when they start passing. Sometimes this isn't possible. |
| 1069 | Often a failing test will cause the whole program to die or hang, even |
| 1070 | inside an C<eval BLOCK> with and using C<alarm>. In these extreme |
| 1071 | cases you have no choice but to skip over the broken tests entirely. |
| 1072 | |
| 1073 | The syntax and behavior is similar to a C<SKIP: BLOCK> except the |
| 1074 | tests will be marked as failing but todo. Test::Harness will |
| 1075 | interpret them as passing. |
| 1076 | |
| 1077 | =cut |
| 1078 | |
| 1079 | sub todo_skip { |
| 1080 | my($why, $how_many) = @_; |
| 1081 | my $tb = Test::More->builder; |
| 1082 | |
| 1083 | unless( defined $how_many ) { |
| 1084 | # $how_many can only be avoided when no_plan is in use. |
| 1085 | _carp "todo_skip() needs to know \$how_many tests are in the block" |
| 1086 | unless $tb->has_plan eq 'no_plan'; |
| 1087 | $how_many = 1; |
| 1088 | } |
| 1089 | |
| 1090 | for( 1..$how_many ) { |
| 1091 | $tb->todo_skip($why); |
| 1092 | } |
| 1093 | |
| 1094 | local $^W = 0; |
| 1095 | last TODO; |
| 1096 | } |
| 1097 | |
| 1098 | =item When do I use SKIP vs. TODO? |
| 1099 | |
| 1100 | B<If it's something the user might not be able to do>, use SKIP. |
| 1101 | This includes optional modules that aren't installed, running under |
| 1102 | an OS that doesn't have some feature (like fork() or symlinks), or maybe |
| 1103 | you need an Internet connection and one isn't available. |
| 1104 | |
| 1105 | B<If it's something the programmer hasn't done yet>, use TODO. This |
| 1106 | is for any code you haven't written yet, or bugs you have yet to fix, |
| 1107 | but want to put tests in your testing script (always a good idea). |
| 1108 | |
| 1109 | |
| 1110 | =back |
| 1111 | |
| 1112 | |
| 1113 | =head2 Test control |
| 1114 | |
| 1115 | =over 4 |
| 1116 | |
| 1117 | =item B<BAIL_OUT> |
| 1118 | |
| 1119 | BAIL_OUT($reason); |
| 1120 | |
| 1121 | Indicates to the harness that things are going so badly all testing |
| 1122 | should terminate. This includes the running any additional test scripts. |
| 1123 | |
| 1124 | This is typically used when testing cannot continue such as a critical |
| 1125 | module failing to compile or a necessary external utility not being |
| 1126 | available such as a database connection failing. |
| 1127 | |
| 1128 | The test will exit with 255. |
| 1129 | |
| 1130 | =cut |
| 1131 | |
| 1132 | sub BAIL_OUT { |
| 1133 | my $reason = shift; |
| 1134 | my $tb = Test::More->builder; |
| 1135 | |
| 1136 | $tb->BAIL_OUT($reason); |
| 1137 | } |
| 1138 | |
| 1139 | =back |
| 1140 | |
| 1141 | |
| 1142 | =head2 Discouraged comparison functions |
| 1143 | |
| 1144 | The use of the following functions is discouraged as they are not |
| 1145 | actually testing functions and produce no diagnostics to help figure |
| 1146 | out what went wrong. They were written before is_deeply() existed |
| 1147 | because I couldn't figure out how to display a useful diff of two |
| 1148 | arbitrary data structures. |
| 1149 | |
| 1150 | These functions are usually used inside an ok(). |
| 1151 | |
| 1152 | ok( eq_array(\@got, \@expected) ); |
| 1153 | |
| 1154 | C<is_deeply()> can do that better and with diagnostics. |
| 1155 | |
| 1156 | is_deeply( \@got, \@expected ); |
| 1157 | |
| 1158 | They may be deprecated in future versions. |
| 1159 | |
| 1160 | =over 4 |
| 1161 | |
| 1162 | =item B<eq_array> |
| 1163 | |
| 1164 | my $is_eq = eq_array(\@got, \@expected); |
| 1165 | |
| 1166 | Checks if two arrays are equivalent. This is a deep check, so |
| 1167 | multi-level structures are handled correctly. |
| 1168 | |
| 1169 | =cut |
| 1170 | |
| 1171 | #'# |
| 1172 | sub eq_array { |
| 1173 | local @Data_Stack; |
| 1174 | _deep_check(@_); |
| 1175 | } |
| 1176 | |
| 1177 | sub _eq_array { |
| 1178 | my($a1, $a2) = @_; |
| 1179 | |
| 1180 | if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { |
| 1181 | warn "eq_array passed a non-array ref"; |
| 1182 | return 0; |
| 1183 | } |
| 1184 | |
| 1185 | return 1 if $a1 eq $a2; |
| 1186 | |
| 1187 | my $ok = 1; |
| 1188 | my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; |
| 1189 | for (0..$max) { |
| 1190 | my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; |
| 1191 | my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; |
| 1192 | |
| 1193 | push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; |
| 1194 | $ok = _deep_check($e1,$e2); |
| 1195 | pop @Data_Stack if $ok; |
| 1196 | |
| 1197 | last unless $ok; |
| 1198 | } |
| 1199 | |
| 1200 | return $ok; |
| 1201 | } |
| 1202 | |
| 1203 | sub _deep_check { |
| 1204 | my($e1, $e2) = @_; |
| 1205 | my $tb = Test::More->builder; |
| 1206 | |
| 1207 | my $ok = 0; |
| 1208 | |
| 1209 | # Effectively turn %Refs_Seen into a stack. This avoids picking up |
| 1210 | # the same referenced used twice (such as [\$a, \$a]) to be considered |
| 1211 | # circular. |
| 1212 | local %Refs_Seen = %Refs_Seen; |
| 1213 | |
| 1214 | { |
| 1215 | # Quiet uninitialized value warnings when comparing undefs. |
| 1216 | local $^W = 0; |
| 1217 | |
| 1218 | $tb->_unoverload_str(\$e1, \$e2); |
| 1219 | |
| 1220 | # Either they're both references or both not. |
| 1221 | my $same_ref = !(!ref $e1 xor !ref $e2); |
| 1222 | my $not_ref = (!ref $e1 and !ref $e2); |
| 1223 | |
| 1224 | if( defined $e1 xor defined $e2 ) { |
| 1225 | $ok = 0; |
| 1226 | } |
| 1227 | elsif ( $e1 == $DNE xor $e2 == $DNE ) { |
| 1228 | $ok = 0; |
| 1229 | } |
| 1230 | elsif ( $same_ref and ($e1 eq $e2) ) { |
| 1231 | $ok = 1; |
| 1232 | } |
| 1233 | elsif ( $not_ref ) { |
| 1234 | push @Data_Stack, { type => '', vals => [$e1, $e2] }; |
| 1235 | $ok = 0; |
| 1236 | } |
| 1237 | else { |
| 1238 | if( $Refs_Seen{$e1} ) { |
| 1239 | return $Refs_Seen{$e1} eq $e2; |
| 1240 | } |
| 1241 | else { |
| 1242 | $Refs_Seen{$e1} = "$e2"; |
| 1243 | } |
| 1244 | |
| 1245 | my $type = _type($e1); |
| 1246 | $type = 'DIFFERENT' unless _type($e2) eq $type; |
| 1247 | |
| 1248 | if( $type eq 'DIFFERENT' ) { |
| 1249 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; |
| 1250 | $ok = 0; |
| 1251 | } |
| 1252 | elsif( $type eq 'ARRAY' ) { |
| 1253 | $ok = _eq_array($e1, $e2); |
| 1254 | } |
| 1255 | elsif( $type eq 'HASH' ) { |
| 1256 | $ok = _eq_hash($e1, $e2); |
| 1257 | } |
| 1258 | elsif( $type eq 'REF' ) { |
| 1259 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; |
| 1260 | $ok = _deep_check($$e1, $$e2); |
| 1261 | pop @Data_Stack if $ok; |
| 1262 | } |
| 1263 | elsif( $type eq 'SCALAR' ) { |
| 1264 | push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; |
| 1265 | $ok = _deep_check($$e1, $$e2); |
| 1266 | pop @Data_Stack if $ok; |
| 1267 | } |
| 1268 | elsif( $type ) { |
| 1269 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; |
| 1270 | $ok = 0; |
| 1271 | } |
| 1272 | else { |
| 1273 | _whoa(1, "No type in _deep_check"); |
| 1274 | } |
| 1275 | } |
| 1276 | } |
| 1277 | |
| 1278 | return $ok; |
| 1279 | } |
| 1280 | |
| 1281 | |
| 1282 | sub _whoa { |
| 1283 | my($check, $desc) = @_; |
| 1284 | if( $check ) { |
| 1285 | die <<WHOA; |
| 1286 | WHOA! $desc |
| 1287 | This should never happen! Please contact the author immediately! |
| 1288 | WHOA |
| 1289 | } |
| 1290 | } |
| 1291 | |
| 1292 | |
| 1293 | =item B<eq_hash> |
| 1294 | |
| 1295 | my $is_eq = eq_hash(\%got, \%expected); |
| 1296 | |
| 1297 | Determines if the two hashes contain the same keys and values. This |
| 1298 | is a deep check. |
| 1299 | |
| 1300 | =cut |
| 1301 | |
| 1302 | sub eq_hash { |
| 1303 | local @Data_Stack; |
| 1304 | return _deep_check(@_); |
| 1305 | } |
| 1306 | |
| 1307 | sub _eq_hash { |
| 1308 | my($a1, $a2) = @_; |
| 1309 | |
| 1310 | if( grep !_type($_) eq 'HASH', $a1, $a2 ) { |
| 1311 | warn "eq_hash passed a non-hash ref"; |
| 1312 | return 0; |
| 1313 | } |
| 1314 | |
| 1315 | return 1 if $a1 eq $a2; |
| 1316 | |
| 1317 | my $ok = 1; |
| 1318 | my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; |
| 1319 | foreach my $k (keys %$bigger) { |
| 1320 | my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; |
| 1321 | my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; |
| 1322 | |
| 1323 | push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; |
| 1324 | $ok = _deep_check($e1, $e2); |
| 1325 | pop @Data_Stack if $ok; |
| 1326 | |
| 1327 | last unless $ok; |
| 1328 | } |
| 1329 | |
| 1330 | return $ok; |
| 1331 | } |
| 1332 | |
| 1333 | =item B<eq_set> |
| 1334 | |
| 1335 | my $is_eq = eq_set(\@got, \@expected); |
| 1336 | |
| 1337 | Similar to eq_array(), except the order of the elements is B<not> |
| 1338 | important. This is a deep check, but the irrelevancy of order only |
| 1339 | applies to the top level. |
| 1340 | |
| 1341 | ok( eq_set(\@got, \@expected) ); |
| 1342 | |
| 1343 | Is better written: |
| 1344 | |
| 1345 | is_deeply( [sort @got], [sort @expected] ); |
| 1346 | |
| 1347 | B<NOTE> By historical accident, this is not a true set comparison. |
| 1348 | While the order of elements does not matter, duplicate elements do. |
| 1349 | |
| 1350 | B<NOTE> eq_set() does not know how to deal with references at the top |
| 1351 | level. The following is an example of a comparison which might not work: |
| 1352 | |
| 1353 | eq_set([\1, \2], [\2, \1]); |
| 1354 | |
| 1355 | Test::Deep contains much better set comparison functions. |
| 1356 | |
| 1357 | =cut |
| 1358 | |
| 1359 | sub eq_set { |
| 1360 | my($a1, $a2) = @_; |
| 1361 | return 0 unless @$a1 == @$a2; |
| 1362 | |
| 1363 | # There's faster ways to do this, but this is easiest. |
| 1364 | local $^W = 0; |
| 1365 | |
| 1366 | # It really doesn't matter how we sort them, as long as both arrays are |
| 1367 | # sorted with the same algorithm. |
| 1368 | # |
| 1369 | # Ensure that references are not accidentally treated the same as a |
| 1370 | # string containing the reference. |
| 1371 | # |
| 1372 | # Have to inline the sort routine due to a threading/sort bug. |
| 1373 | # See [rt.cpan.org 6782] |
| 1374 | # |
| 1375 | # I don't know how references would be sorted so we just don't sort |
| 1376 | # them. This means eq_set doesn't really work with refs. |
| 1377 | return eq_array( |
| 1378 | [grep(ref, @$a1), sort( grep(!ref, @$a1) )], |
| 1379 | [grep(ref, @$a2), sort( grep(!ref, @$a2) )], |
| 1380 | ); |
| 1381 | } |
| 1382 | |
| 1383 | =back |
| 1384 | |
| 1385 | |
| 1386 | =head2 Extending and Embedding Test::More |
| 1387 | |
| 1388 | Sometimes the Test::More interface isn't quite enough. Fortunately, |
| 1389 | Test::More is built on top of Test::Builder which provides a single, |
| 1390 | unified backend for any test library to use. This means two test |
| 1391 | libraries which both use Test::Builder B<can be used together in the |
| 1392 | same program>. |
| 1393 | |
| 1394 | If you simply want to do a little tweaking of how the tests behave, |
| 1395 | you can access the underlying Test::Builder object like so: |
| 1396 | |
| 1397 | =over 4 |
| 1398 | |
| 1399 | =item B<builder> |
| 1400 | |
| 1401 | my $test_builder = Test::More->builder; |
| 1402 | |
| 1403 | Returns the Test::Builder object underlying Test::More for you to play |
| 1404 | with. |
| 1405 | |
| 1406 | |
| 1407 | =back |
| 1408 | |
| 1409 | |
| 1410 | =head1 EXIT CODES |
| 1411 | |
| 1412 | If all your tests passed, Test::Builder will exit with zero (which is |
| 1413 | normal). If anything failed it will exit with how many failed. If |
| 1414 | you run less (or more) tests than you planned, the missing (or extras) |
| 1415 | will be considered failures. If no tests were ever run Test::Builder |
| 1416 | will throw a warning and exit with 255. If the test died, even after |
| 1417 | having successfully completed all its tests, it will still be |
| 1418 | considered a failure and will exit with 255. |
| 1419 | |
| 1420 | So the exit codes are... |
| 1421 | |
| 1422 | 0 all tests successful |
| 1423 | 255 test died or all passed but wrong # of tests run |
| 1424 | any other number how many failed (including missing or extras) |
| 1425 | |
| 1426 | If you fail more than 254 tests, it will be reported as 254. |
| 1427 | |
| 1428 | B<NOTE> This behavior may go away in future versions. |
| 1429 | |
| 1430 | |
| 1431 | =head1 CAVEATS and NOTES |
| 1432 | |
| 1433 | =over 4 |
| 1434 | |
| 1435 | =item Backwards compatibility |
| 1436 | |
| 1437 | Test::More works with Perls as old as 5.004_05. |
| 1438 | |
| 1439 | |
| 1440 | =item Overloaded objects |
| 1441 | |
| 1442 | String overloaded objects are compared B<as strings> (or in cmp_ok()'s |
| 1443 | case, strings or numbers as appropriate to the comparison op). This |
| 1444 | prevents Test::More from piercing an object's interface allowing |
| 1445 | better blackbox testing. So if a function starts returning overloaded |
| 1446 | objects instead of bare strings your tests won't notice the |
| 1447 | difference. This is good. |
| 1448 | |
| 1449 | However, it does mean that functions like is_deeply() cannot be used to |
| 1450 | test the internals of string overloaded objects. In this case I would |
| 1451 | suggest Test::Deep which contains more flexible testing functions for |
| 1452 | complex data structures. |
| 1453 | |
| 1454 | |
| 1455 | =item Threads |
| 1456 | |
| 1457 | Test::More will only be aware of threads if "use threads" has been done |
| 1458 | I<before> Test::More is loaded. This is ok: |
| 1459 | |
| 1460 | use threads; |
| 1461 | use Test::More; |
| 1462 | |
| 1463 | This may cause problems: |
| 1464 | |
| 1465 | use Test::More |
| 1466 | use threads; |
| 1467 | |
| 1468 | 5.8.1 and above are supported. Anything below that has too many bugs. |
| 1469 | |
| 1470 | |
| 1471 | =item Test::Harness upgrade |
| 1472 | |
| 1473 | no_plan and todo depend on new Test::Harness features and fixes. If |
| 1474 | you're going to distribute tests that use no_plan or todo your |
| 1475 | end-users will have to upgrade Test::Harness to the latest one on |
| 1476 | CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness |
| 1477 | will work fine. |
| 1478 | |
| 1479 | Installing Test::More should also upgrade Test::Harness. |
| 1480 | |
| 1481 | =back |
| 1482 | |
| 1483 | |
| 1484 | =head1 HISTORY |
| 1485 | |
| 1486 | This is a case of convergent evolution with Joshua Pritikin's Test |
| 1487 | module. I was largely unaware of its existence when I'd first |
| 1488 | written my own ok() routines. This module exists because I can't |
| 1489 | figure out how to easily wedge test names into Test's interface (along |
| 1490 | with a few other problems). |
| 1491 | |
| 1492 | The goal here is to have a testing utility that's simple to learn, |
| 1493 | quick to use and difficult to trip yourself up with while still |
| 1494 | providing more flexibility than the existing Test.pm. As such, the |
| 1495 | names of the most common routines are kept tiny, special cases and |
| 1496 | magic side-effects are kept to a minimum. WYSIWYG. |
| 1497 | |
| 1498 | |
| 1499 | =head1 SEE ALSO |
| 1500 | |
| 1501 | L<Test::Simple> if all this confuses you and you just want to write |
| 1502 | some tests. You can upgrade to Test::More later (it's forward |
| 1503 | compatible). |
| 1504 | |
| 1505 | L<Test> is the old testing module. Its main benefit is that it has |
| 1506 | been distributed with Perl since 5.004_05. |
| 1507 | |
| 1508 | L<Test::Harness> for details on how your test results are interpreted |
| 1509 | by Perl. |
| 1510 | |
| 1511 | L<Test::Differences> for more ways to test complex data structures. |
| 1512 | And it plays well with Test::More. |
| 1513 | |
| 1514 | L<Test::Class> is like XUnit but more perlish. |
| 1515 | |
| 1516 | L<Test::Deep> gives you more powerful complex data structure testing. |
| 1517 | |
| 1518 | L<Test::Unit> is XUnit style testing. |
| 1519 | |
| 1520 | L<Test::Inline> shows the idea of embedded testing. |
| 1521 | |
| 1522 | L<Bundle::Test> installs a whole bunch of useful test modules. |
| 1523 | |
| 1524 | |
| 1525 | =head1 AUTHORS |
| 1526 | |
| 1527 | Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration |
| 1528 | from Joshua Pritikin's Test module and lots of help from Barrie |
| 1529 | Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and |
| 1530 | the perl-qa gang. |
| 1531 | |
| 1532 | |
| 1533 | =head1 BUGS |
| 1534 | |
| 1535 | See F<http://rt.cpan.org> to report and view bugs. |
| 1536 | |
| 1537 | |
| 1538 | =head1 COPYRIGHT |
| 1539 | |
| 1540 | Copyright 2001-2002, 2004-2006 by Michael G Schwern E<lt>schwern@pobox.comE<gt>. |
| 1541 | |
| 1542 | This program is free software; you can redistribute it and/or |
| 1543 | modify it under the same terms as Perl itself. |
| 1544 | |
| 1545 | See F<http://www.perl.com/perl/misc/Artistic.html> |
| 1546 | |
| 1547 | =cut |
| 1548 | |
| 1549 | 1; |